From patchwork Tue Aug 6 09:02:40 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Marc_Poulhi=C3=A8s?= X-Patchwork-Id: 1969389 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=adacore.com header.i=@adacore.com header.a=rsa-sha256 header.s=google header.b=fRvpwig1; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4WdS8y0SP2z1ydt for ; Tue, 6 Aug 2024 19:06:25 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3A28F385B50B for ; Tue, 6 Aug 2024 09:06:24 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wm1-x331.google.com (mail-wm1-x331.google.com [IPv6:2a00:1450:4864:20::331]) by sourceware.org (Postfix) with ESMTPS id 24D91385E45C for ; Tue, 6 Aug 2024 09:03:31 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 24D91385E45C Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=adacore.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 24D91385E45C Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2a00:1450:4864:20::331 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722935018; cv=none; b=bD5Xu9iv1ZJhO5ImeovbWQk+0DY7mpR8YNDeZiApJil7HGVhgRBufxfkRSDlEnJZ9+jo1QkRaf9TzllfoLMmy3pZswjyNmZYflOG9x7Rhe60laIjj30NcpVMaJ9wZGf8E51BugNzrDzyeB90+Tiwe3IZa2QEi17kWenin4jQOkc= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1722935018; c=relaxed/simple; bh=OF/WQfuDEtgH0s4tJz/U3XVxltdtuXn/hm7kwz7XldQ=; h=DKIM-Signature:From:To:Subject:Date:Message-ID:MIME-Version; b=aCq8nhgeiPzJd/+0Fe72xR6SnUBU6F9wBSSyeNesPKMkBwzxuq09imL57jjkr7dckMbea/SD8AoSLMaOuqOFuhfUni8VyVf+rO+uV8wz9PbLiJZyvUteQrbGOHdu5+OtQD1JOqVmpxL5Y/bH40JxMsa22DQn0REjwGJdkTa+A0M= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-wm1-x331.google.com with SMTP id 5b1f17b1804b1-428243f928cso2703075e9.3 for ; Tue, 06 Aug 2024 02:03:31 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=adacore.com; s=google; t=1722935009; x=1723539809; darn=gcc.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=LQmB+iNWHrX//zBkdaa6MbffxNHRh4IwqXv6V6yjbGg=; b=fRvpwig1/wyoeYGSnWFFAJkr1LF3N+8MB96NDWAYwOvuUEBGwAEUaSsLr9WHg6MZpL E7aTpeiwY/2uLdYrt0SA68V7ALQkSMWoXCcMZzkBrUNcpDb9X9P87WKIebGVlAoB245q AFZ20wupYh+E+bpCyvuZBNAQoewA54aeGsMuLBdVQOPLQzkjamdBKrmkb/vbfoOh5h6Q lefwU22Kg8YNzceJt98OwHhexOU2YRiyKKrJAM/O1lDX5Zg3Hs4VkoY1bTOoQ29lhBh2 SLggHd8KBBYu+b8jBa31allI7xN8sWQ1rHFkRES9X7tYWPKwUMgEDG0/vGJ2OxG11fW9 UgrA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1722935009; x=1723539809; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=LQmB+iNWHrX//zBkdaa6MbffxNHRh4IwqXv6V6yjbGg=; b=aJqNRJUhwwepzwT/bP/lQTJWv546swO5C0/HexPNFFt3bQSxUqbdAFYfso0PXQuJ/F sDzzSETBHYuKrzWpeCC+BDKkc4mT5xhS1e2nNLnfhenGNUwC3oZexavEefdwxSgRlgvK sVrk6c7ZaVLUfPbax6STUcVii3dhsdf+goWrU53L9erxlk9mCDv729CxMjuOMfnB+piC jiFGF486/V6R7CPMrmcKUMsHF2jJAG9GMzWONO0JC5aDQANQ+7uWTg0GXmmeZulpGu30 8MRDzsNyinWmRCWi2F2Z7kIFyZ9D1s5+xAe+OLpaL3r2VpSRh79vwDEvMSkDMTZTZpZA nrXw== X-Gm-Message-State: AOJu0Yx5t+mXGsn0D2FKqi3jcEK9hyrPBRfpnFkYk16ZMoaRKczT18tw 2+1uMjXzgI60h5nzfePufE/vFFE70Bd2O3jYXK4ATlmjBwgWUoPzT7iMM8kxGZ2dzbHoImtY5/j O5Q== X-Google-Smtp-Source: AGHT+IGnxv2dFSc8L4SWWUOMqFkSKsTgsBiT4V60GnBanhg1VMmW4s32jvKlK78Ogt6jfDajsEaEjA== X-Received: by 2002:a05:600c:3112:b0:426:59fc:cdec with SMTP id 5b1f17b1804b1-428e6b30300mr95491135e9.21.1722934979412; Tue, 06 Aug 2024 02:02:59 -0700 (PDT) Received: from poulhies-Precision-5550.telnowedge.local (lmontsouris-659-1-24-67.w81-250.abo.wanadoo.fr. [81.250.175.67]) by smtp.gmail.com with ESMTPSA id 5b1f17b1804b1-428e6e03c4csm173461085e9.13.2024.08.06.02.02.58 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 06 Aug 2024 02:02:58 -0700 (PDT) From: =?utf-8?q?Marc_Poulhi=C3=A8s?= To: gcc-patches@gcc.gnu.org Cc: Bob Duff Subject: [COMMITTED 8/9] ada: Implement type inference for generic parameters Date: Tue, 6 Aug 2024 11:02:40 +0200 Message-ID: <20240806090241.576862-8-poulhies@adacore.com> X-Mailer: git-send-email 2.45.2 In-Reply-To: <20240806090241.576862-1-poulhies@adacore.com> References: <20240806090241.576862-1-poulhies@adacore.com> MIME-Version: 1.0 X-Spam-Status: No, score=-13.3 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, GIT_PATCH_0, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces~incoming=patchwork.ozlabs.org@gcc.gnu.org From: Bob Duff ...based on previous work that added Gen_Assocs_Rec. Minor cleanup of that previous work. gcc/ada/ * sem_ch12.adb: Implement type inference for generic parameters. (Maybe_Infer_One): Forbid inference of anonymous subtypes and types. (Inference_Reason): Fix comment. * debug.adb: Document -gnatd_I switch. * errout.ads: Document that Empty is not allowed for "&". * errout.adb (Set_Msg_Insertion_Node): Minor: Do not allow Error_Msg_Node_1 = Empty for "&". Use "in" instead of multiple "=". Improve comment. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/debug.adb | 5 +- gcc/ada/errout.adb | 23 +-- gcc/ada/errout.ads | 11 +- gcc/ada/sem_ch12.adb | 482 +++++++++++++++++++++++++++++++++++++++++-- 4 files changed, 485 insertions(+), 36 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index d2546bec1b5..fcd04dfb93b 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -173,7 +173,7 @@ package body Debug is -- d_F Encode full invocation paths in ALI files -- d_G -- d_H - -- d_I + -- d_I Note generic formal type inference -- d_J -- d_K (Reserved) Enable reporting a warning on known-problem issues -- d_L Output trace information on elaboration checking @@ -1029,6 +1029,9 @@ package body Debug is -- an external target, offering additional information to GNATBIND for -- purposes of error diagnostics. + -- d_I Generic formal type inference: print a "note:" message for each + -- actual type that is inferred, or could be inferred. + -- d_K (Reserved) Enable reporting a warning on known-problem issues of -- previous releases. No action performed in the wavefront. diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index c6534fe2a76..c8d87f0f9bb 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -3866,18 +3866,13 @@ package body Errout is ---------------------------- procedure Set_Msg_Insertion_Node is + pragma Assert (Present (Error_Msg_Node_1)); K : Node_Kind; begin - Suppress_Message := - Error_Msg_Node_1 = Error - or else Error_Msg_Node_1 = Any_Type; + Suppress_Message := Error_Msg_Node_1 in Error | Any_Type; - if Error_Msg_Node_1 = Empty then - Set_Msg_Blank_Conditional; - Set_Msg_Str (""); - - elsif Error_Msg_Node_1 = Error then + if Error_Msg_Node_1 = Error then Set_Msg_Blank; Set_Msg_Str (""); @@ -3898,15 +3893,11 @@ package body Errout is K := Nkind (Error_Msg_Node_1); - -- If we have operator case, skip quotes since name of operator - -- itself will supply the required quotations. An operator can be an - -- applied use in an expression or an explicit operator symbol, or an - -- identifier whose name indicates it is an operator. + -- Skip quotes in the operator case, because the operator will supply + -- the required quotes. - if K in N_Op - or else K = N_Operator_Symbol - or else K = N_Defining_Operator_Symbol - or else ((K = N_Identifier or else K = N_Defining_Identifier) + if K in N_Op | N_Operator_Symbol | N_Defining_Operator_Symbol + or else (K in N_Identifier | N_Defining_Identifier and then Is_Operator_Name (Chars (Error_Msg_Node_1))) then Set_Msg_Node (Error_Msg_Node_1); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index f0e3f5d0b7c..2b0410ae690 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -173,12 +173,11 @@ package Errout is -- obtained from the Sloc field of the given node or nodes. If no Sloc -- is available (happens e.g. for nodes in package Standard), then the -- default case (see Scans spec) is used. The nodes to be used are - -- stored in Error_Msg_Node_1, Error_Msg_Node_2. No insertion occurs - -- for the Empty node, and the Error node results in the insertion of - -- the characters . In addition, if the special global variable - -- Error_Msg_Qual_Level is non-zero, then the reference will include - -- up to the given number of levels of qualification, using the scope - -- chain. + -- stored in Error_Msg_Node_1, Error_Msg_Node_2, which must not be + -- Empty. The Error node results in the insertion of "". In + -- addition, if the special global variable Error_Msg_Qual_Level is + -- non-zero, then the reference will include up to the given number of + -- levels of qualification, using the scope chain. -- -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed -- to insert the string xxx'Class into the message. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 25821cb7695..0f8792c3a82 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -26,6 +26,7 @@ with Aspects; use Aspects; with Atree; use Atree; with Contracts; use Contracts; +with Debug; use Debug; with Einfo; use Einfo; with Einfo.Entities; use Einfo.Entities; with Einfo.Utils; use Einfo.Utils; @@ -830,7 +831,7 @@ package body Sem_Ch12 is -- formal derived types, to determine whether the parent type is another -- formal derived type in the same generic unit. -- Note that the call site appends the result of this function onto - -- the same list. + -- the same list it is passing to Actual_Decls. function Instantiate_Formal_Subprogram (Formal : Node_Id; @@ -1167,9 +1168,26 @@ package body Sem_Ch12 is end record; type Actual_Origin_Enum is - (None, From_Explicit_Actual, From_Default, From_Others_Box); + (None, From_Explicit_Actual, From_Default, From_Inference, + From_Others_Box); -- Indication of where the Actual came from -- explicitly in the - -- instantiation, or defaulted. + -- instantiation, inferred from some other type, or defaulted. + + type Inference_Reason is + -- Reason an actual type corresponding to a formal type was (or could + -- be) inferred from the actual type corresponding to another formal + -- type. + (Designated_Type, -- designated type from formal access + Index_Type, -- index type from formal array + Component_Type, -- component type from formal array + Discriminant_Type); -- discriminant type from formal discriminated + + function Image (Reason : Inference_Reason) return String is + (case Reason is + when Designated_Type => "designated type", + when Index_Type => "index type", + when Component_Type => "component type", + when Discriminant_Type => "discriminant type"); type Assoc_Index is new Pos; subtype Assoc_Count is Assoc_Index'Base range 0 .. Assoc_Index'Last; @@ -1196,7 +1214,22 @@ package body Sem_Ch12 is Actual_Origin : Actual_Origin_Enum; -- Reason why Actual was set; where it came from - end record; + + Info_Inferred_Actual : Opt_Type_Kind_Id; + -- An inferred actual is always a type entity, not a box, and not + -- something like T'Base. This is used only for messages and + -- assertions. It contains the type that was, or could have been, + -- inferred. + + Inferred_From : Assoc_Index; + -- Index of a later Assoc_Rec in the same Gen_Assocs_Rec from which + -- this one was inferred, or could be inferred. + -- Valid only if Info_Inferred_Actual is present. + + Reason : Inference_Reason; + -- Reason the type was inferred, or could have been inferred. + -- Valid only if Info_Inferred_Actual is present. + end record; -- Assoc_Rec type Assoc_Array is array (Assoc_Index range <>) of Assoc_Rec; -- One element for each formal and (if legal) for each corresponding @@ -1206,9 +1239,13 @@ package body Sem_Ch12 is -- Representation of formal/actual matching. Num_Assocs -- is the number of formals and (if legal) the number -- of actuals. + Gen_Unit : Entity_Id; + -- the generic unit being instantiated Others_Present : Boolean; -- True if "others => <>" (only for formal packages) Assocs : Assoc_Array (1 .. Num_Assocs); + -- One for each formal/actual pair; defaulted and inferred actuals + -- are included. end record; function Match_Assocs @@ -1220,6 +1257,11 @@ package body Sem_Ch12 is -- actuals filled in. Check legality rules related to formal/actual -- matching. + procedure Note_Potential_Inference + (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec); + -- If -gnatd_I, print "info:" messages about type inference that could + -- have been done. + end Associations; procedure Analyze_One_Association @@ -1298,6 +1340,52 @@ package body Sem_Ch12 is -- and we set Assoc.Actual. We also set the Selector_Name to denote -- the matched formal, and set Found to True. + procedure Inference_Msg + (Gen_Unit : Entity_Id; + Inferred_To, Inferred_From : Assoc_Rec; + Was_Inferred : Boolean); + -- If Was_Inferred is True, this prints out an "info:" message + -- showing the inference. + -- If Was_Inferred is False, the message says that it could have + -- been inferred. + + function Find_Assoc + (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index; + -- Return the index of F in Gen_Assocs.Assocs, which must be + -- present. + + procedure Maybe_Infer_One + (Gen_Assocs : in out Gen_Assocs_Rec; + FF, AA : N_Entity_Id; Inferred_From : Assoc_Index; + Reason : Inference_Reason); + -- If it makes sense to infer that formal FF is associated with + -- actual AA, then do so. + + procedure Infer_From_Access + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id); + -- Try to infer the designated type + + procedure Infer_From_Array + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id); + -- Try to infer the index and component types + + procedure Infer_From_Discriminated + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id); + -- Try to infer the types of discriminants + + procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec); + -- Called by Match_Assocs after processing explicit and defaulted + -- parameters to infer any that are still missing. + ----------------- -- Formal_Iter -- ----------------- @@ -1380,6 +1468,8 @@ package body Sem_Ch12 is Action (F, Index); Index := Index + 1; + -- Skip full type of derived type + if Nkind (F) = N_Full_Type_Declaration and then Nkind (Type_Definition (F)) = N_Derived_Type_Definition @@ -1388,7 +1478,7 @@ package body Sem_Ch12 is and then Chars (Defining_Identifier (F)) = Chars (Defining_Identifier (Next (F))) then - Next (F); -- Skip full type of derived type + Next (F); end if; end if; @@ -1399,22 +1489,28 @@ package body Sem_Ch12 is (not Is_Internal_Name (Chars (Defining_Entity (F)))); Action (F, Index); Index := Index + 1; + elsif Nkind (Original_Node (F)) in N_Full_Type_Declaration then null; else -- subtype of a formal object + pragma Assert (Nkind (Next (F)) = N_Formal_Object_Declaration); end if; + when N_Pragma => null; + when N_Formal_Package_Declaration => -- If there were no errors, this would have been transformed - -- into N_Package_Declaration. + -- into an N_Package_Declaration. + Check_Error_Detected; pragma Assert (Error_Posted (F)); Abandon_Instantiation (Instantiation_Node); + when others => raise Program_Error; end case; @@ -1509,6 +1605,7 @@ package body Sem_Ch12 is end if; when N_Formal_Package_Declaration => null; + when others => raise Program_Error; end case; pragma Assert @@ -1640,12 +1737,16 @@ package body Sem_Ch12 is return Result : Gen_Assocs_Rec (Num_Assocs => Num_Formals (Formals)) do + Result.Gen_Unit := Gen_Unit; Result.Others_Present := False; -- Loop through the unanalyzed formals: declare procedure Set_Formal (F : Node_Id; Index : Assoc_Index); + -- Initialize one Assoc_Rec so the formal is set. + -- Use a dummy assoc for use clauses. + procedure Set_Formal (F : Node_Id; Index : Assoc_Index) is Assoc : Assoc_Rec renames Result.Assocs (Index); begin @@ -1655,14 +1756,20 @@ package body Sem_Ch12 is An_Formal => Empty, Explicit_Assoc => Empty, Actual => (Kind => None_Use_Clause), - Actual_Origin => None); + Actual_Origin => None, + Info_Inferred_Actual => Empty, + Inferred_From => <>, + Reason => <>); else Assoc := (Un_Formal => F, An_Formal => Empty, Explicit_Assoc => Empty, Actual => <>, - Actual_Origin => None); + Actual_Origin => None, + Info_Inferred_Actual => Empty, + Inferred_From => <>, + Reason => <>); end if; end Set_Formal; procedure Iter is new Formal_Iter (Set_Formal); @@ -1812,6 +1919,7 @@ package body Sem_Ch12 is -- if there is "others => <>", set the actual to "F => <>". -- Otherwise, if the formal has a default, set the actual to -- "F => default". Otherwise leave it Empty. + -- (If Empty, it could be inferred, or it could be an error). for Index in Result.Assocs'Range loop declare @@ -1832,6 +1940,10 @@ package body Sem_Ch12 is end; end loop; + if Nkind (I_Node) /= N_Formal_Package_Declaration then + Infer_Actuals (Gen_Assocs => Result); + end if; + -- Check for missing actuals for Index in Result.Assocs'Range loop @@ -1850,6 +1962,331 @@ package body Sem_Ch12 is end return; end Match_Assocs; + ------------------- + -- Inference_Msg -- + ------------------- + + procedure Inference_Msg + (Gen_Unit : Entity_Id; + Inferred_To, Inferred_From : Assoc_Rec; + Was_Inferred : Boolean) + is + pragma Assert (Debug_Flag_Underscore_II); -- This is only for -gnatd_I + + Was : constant String := (if Was_Inferred then "" else "could have "); + + -- "if True" below to leave out some verbosity for now: + Inst : constant String := + (if True then "" + else " gen: " & Get_Name_String (Chars (Gen_Unit))); + Decl : constant String := (if True then "" else " declared # "); + + R : constant String := " (" & Image (Inferred_To.Reason) & ")"; + + Mess : constant String := + "info: " & Was & "inferred `% ='> &`" & Decl & Inst & R; + Mess_2 : constant String := + "info: `% ='> ...`"; + begin + Error_Msg_Name_1 := Chars (Defining_Entity (Inferred_To.An_Formal)); + Error_Msg_Sloc := Sloc (Inferred_To.Info_Inferred_Actual); + if not In_Instance then + if Debug_Flag_Underscore_II then + Error_Msg_NE + (Mess, Inferred_From.Actual.Name_Exp, + Inferred_To.Info_Inferred_Actual); + Error_Msg_Name_1 := + Chars (Defining_Identifier (Inferred_From.An_Formal)); + Error_Msg_N (Mess_2, Inferred_From.Actual.Name_Exp); + end if; + end if; + end Inference_Msg; + + ------------------------------ + -- Note_Potential_Inference -- + ------------------------------ + + procedure Note_Potential_Inference + (I_Node : Node_Id; Gen_Assocs : Gen_Assocs_Rec) + is + begin + if not Debug_Flag_Underscore_II or else Serious_Errors_Detected > 0 + then + return; + end if; + + for Index in Gen_Assocs.Assocs'Range loop + declare + Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index); + begin + if Assoc.Actual_Origin = From_Explicit_Actual + and then Present (Assoc.Info_Inferred_Actual) + and then In_Extended_Main_Source_Unit (I_Node) + and then not In_Internal_Unit (I_Node) + then + Inference_Msg + (Gen_Assocs.Gen_Unit, + Inferred_To => Assoc, + Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From), + Was_Inferred => False); + end if; + end; + end loop; + end Note_Potential_Inference; + + -------------- + -- Find_Assoc -- + -------------- + + function Find_Assoc + (Gen_Assocs : Gen_Assocs_Rec; F : Entity_Id) return Assoc_Index + is + begin + for Index in Gen_Assocs.Assocs'Range loop + if Defining_Entity (Gen_Assocs.Assocs (Index).An_Formal) = F then + return Index; + end if; + end loop; + + raise Program_Error; -- it must be present + end Find_Assoc; + + --------------------- + -- Maybe_Infer_One -- + --------------------- + + procedure Maybe_Infer_One + (Gen_Assocs : in out Gen_Assocs_Rec; + FF, AA : N_Entity_Id; Inferred_From : Assoc_Index; + Reason : Inference_Reason) + is + begin + if not (Is_Generic_Type (FF) + and then Scope (FF) = Gen_Assocs.Gen_Unit) + then + return; -- no inference if not a formal type of this generic + end if; + + if Is_Internal_Name (Chars (FF)) or else Is_Itype (AA) then + return; -- no inference if internally generated + end if; + + declare + Index : constant Assoc_Index := Find_Assoc (Gen_Assocs, FF); + Assoc : Assoc_Rec renames Gen_Assocs.Assocs (Index); + pragma Assert (Defining_Entity (Assoc.An_Formal) = FF); + + From_Actual : constant Node_Id := + Gen_Assocs.Assocs (Inferred_From).Actual.Name_Exp; + + begin + Assoc.Info_Inferred_Actual := AA; + Assoc.Inferred_From := Inferred_From; + Assoc.Reason := Reason; + + if Assoc.Actual.Kind = None then + Assoc.Actual := + (Name_Exp, New_Occurrence_Of (AA, Sloc (From_Actual))); + Assoc.Actual_Origin := From_Inference; + + Error_Msg_GNAT_Extension + ("type inference of generic parameters", + Sloc (From_Actual)); + + if Debug_Flag_Underscore_II then + Inference_Msg + (Gen_Assocs.Gen_Unit, + Inferred_To => Assoc, + Inferred_From => Gen_Assocs.Assocs (Assoc.Inferred_From), + Was_Inferred => True); + end if; + end if; + end; + end Maybe_Infer_One; + + ------------------- + -- Infer_Actuals -- + ------------------- + + procedure Infer_From_Access + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id) + is + begin + if Ekind (A_Full) in Access_Kind then + declare + FF : constant Entity_Id := + Designated_Type (Defining_Entity (F)); + AA : constant Entity_Id := Designated_Type (A_Full); + begin + Maybe_Infer_One + (Gen_Assocs, + FF, + AA, + Inferred_From => Index, + Reason => Designated_Type); + end; + end if; + end Infer_From_Access; + + procedure Infer_From_Array + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id) + is + begin + if Ekind (A_Full) in Array_Kind then + declare + F_Index_Type : Opt_N_Is_Index_Id := + First_Index (Defining_Entity (F)); + A_Index_Type : Opt_N_Is_Index_Id := + First_Index (A_Full); + begin + while Present (F_Index_Type) and then Present (A_Index_Type) + loop + Maybe_Infer_One + (Gen_Assocs, + Etype (F_Index_Type), + Etype (A_Index_Type), + Inferred_From => Index, + Reason => Index_Type); + + Next_Index (F_Index_Type); + Next_Index (A_Index_Type); + end loop; + end; + + declare + F_Comp_Type : constant Type_Kind_Id := + Component_Type (Defining_Entity (F)); + A_Comp_Type : constant Type_Kind_Id := + Component_Type (A_Full); + begin + Maybe_Infer_One + (Gen_Assocs, + F_Comp_Type, + A_Comp_Type, + Inferred_From => Index, + Reason => Component_Type); + end; + end if; + end Infer_From_Array; + + procedure Infer_From_Discriminated + (Gen_Assocs : in out Gen_Assocs_Rec; + Index : Assoc_Index; + F : Node_Id; + A_Full : Entity_Id) + is + begin + if Has_Discriminants (Defining_Entity (F)) + and then Present (A_Full) + and then Has_Discriminants (A_Full) + and then Number_Discriminants (A_Full) = + Number_Discriminants (Defining_Entity (F)) + then + declare + F_Discrim : Node_Id := First_Discriminant (Defining_Entity (F)); + A_Discrim : Node_Id := First_Discriminant (A_Full); + begin + while Present (F_Discrim) loop + Maybe_Infer_One + (Gen_Assocs, + Etype (F_Discrim), + Etype (A_Discrim), + Inferred_From => Index, + Reason => Discriminant_Type); + + Next_Discriminant (F_Discrim); + Next_Discriminant (A_Discrim); + end loop; + pragma Assert (No (A_Discrim)); -- same number as F_Discrim + end; + end if; + end Infer_From_Discriminated; + + procedure Infer_Actuals (Gen_Assocs : in out Gen_Assocs_Rec) is + -- Note that we can infer FROM defaults, but we cannot infer TO a + -- parameter that has a default. We can also infer from inferred + -- types. + + -- We don't need to check that multiple inferences get the same + -- answer; the second one will get a type mismatch or nonstatically + -- matching error. + + -- This code needs to be robust, in the sense of tolerating illegal + -- code, because we have not yet checked all legality rules. For + -- example, if a formal type F has a discriminant whose type is + -- another formal type, then we want to infer the type of the + -- discriminant from the actual for F. That actual must have + -- discriminants, but we have not checked that rule yet, so we + -- need to tolerate an actual for F that has no discriminants. + + begin + -- For each parameter, check whether we can infer FROM that one TO + -- other ones. + + -- Process the parameters in reverse order, because the inferred type + -- always comes before the parameter it is inferred from. This + -- ensures that we can do the inference in one pass, including in + -- cases where an inferred type leads to another inferred type. + -- For example, an array type that allows us to infer the component + -- type, which is an access type that allows us to infer the + -- designated type. The reverse loop implies that we will see the + -- array type, then the access type, then the designated type. + + for Index in reverse Gen_Assocs.Assocs'Range loop -- NB: "reverse" + if Gen_Assocs.Assocs (Index).Actual.Kind = Name_Exp then + declare + F : constant Node_Id := Gen_Assocs.Assocs (Index).An_Formal; + A_E : constant Node_Id := + Gen_Assocs.Assocs (Index).Actual.Name_Exp; + A_Full : Entity_Id := Empty; + begin + if Nkind (A_E) in N_Has_Entity then + A_Full := Entity (A_E); + + if Present (A_Full) + and then Ekind (A_Full) in Incomplete_Kind + and then Present (Full_View (A_Full)) + then + A_Full := Full_View (A_Full); + end if; + end if; + + if Nkind (F) = N_Formal_Type_Declaration + and then Present (A_Full) + then + case Ekind (Defining_Entity (F)) is + when E_Access_Type | E_General_Access_Type => + Infer_From_Access (Gen_Assocs, Index, F, A_Full); + + when E_Access_Subtype + | E_Access_Attribute_Type + | E_Allocator_Type + | E_Anonymous_Access_Type => + raise Program_Error; + + when E_Array_Type | E_Array_Subtype => + Infer_From_Array (Gen_Assocs, Index, F, A_Full); + + when E_String_Literal_Subtype => + raise Program_Error; + + when others => + null; + end case; + + Infer_From_Discriminated (Gen_Assocs, Index, F, A_Full); + end if; + end; + end if; + end loop; + end Infer_Actuals; + end Associations; --------------------------- @@ -1902,8 +2339,7 @@ package body Sem_Ch12 is and then Error_Posted (Assoc.An_Formal) then -- Restrict this to N_Formal_Package_Declaration, - -- because otherwise many test diffs (and maybe - -- many missing errors). + -- because otherwise we miss errors. Abandon_Instantiation (Instantiation_Node); end if; @@ -1957,6 +2393,8 @@ package body Sem_Ch12 is end; end if; + Note_Potential_Inference (I_Node, Gen_Assocs); + Check_Fixed_Point_Warning (Gen_Assocs, Result_Renamings); return Result_Renamings; @@ -2007,6 +2445,8 @@ package body Sem_Ch12 is -- Start of processing for Analyze_One_Association begin + pragma Assert (Assoc.Actual_Origin /= None); + if Assoc.Actual_Origin = From_Explicit_Actual and then Assoc.Actual.Kind = Name_Exp then @@ -2066,6 +2506,8 @@ package body Sem_Ch12 is Process_Box_Actual (Assoc.Un_Formal); elsif No (Match) then + -- No explicit actual; try default + if Present (Default_Subtype_Mark (Assoc.Un_Formal)) then Match := New_Copy (Default_Subtype_Mark (Assoc.Un_Formal)); Append_List @@ -2074,6 +2516,21 @@ package body Sem_Ch12 is Result_Renamings), Result_Renamings); Append_Elmt (Entity (Match), Actuals_To_Freeze); + + -- No explicit actual and no default; must be inference + + else + pragma Assert (Assoc.Actual_Origin = From_Inference); + + Match := Assoc.Actual.Name_Exp; + Append_List + (Instantiate_Type + (Assoc.Un_Formal, + Match, + Assoc.An_Formal, + Result_Renamings), + Result_Renamings); + Append_Elmt (Entity (Match), Actuals_To_Freeze); end if; else @@ -16627,11 +17084,10 @@ package body Sem_Ch12 is -- Note that we are creating an N_Generic_Association with -- neither Explicit_Generic_Actual_Parameter nor Box_Present. - elsif Present (Next (Act2)) and True then + elsif Present (Next (Act2)) then Ndec := Make_Generic_Association (Loc, - Selector_Name => - New_Occurrence_Of (Subp, Loc), + Selector_Name => New_Occurrence_Of (Subp, Loc), Explicit_Generic_Actual_Parameter => Empty); Append (Ndec, Assoc1);