===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -7521,6 +7521,15 @@
is
Pref_Typ : constant Entity_Id := Etype (Prefix);
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Par : Node_Id) return Boolean;
+ -- Find formal corresponding to given indexed component that is an
+ -- actual in a call. Note that the enclosing subprogram call has not
+ -- beenanalyzed yet, and the parameter list is not normalized, so
+ -- that if the argument is a parameter association we must match it
+ -- by name and not by position.
+
function Constant_Indexing_OK return Boolean;
-- Constant_Indexing is legal if there is no Variable_Indexing defined
-- for the type, or else node not a target of assignment, or an actual
@@ -7535,6 +7544,56 @@
-- interpretations. Flag Is_Constant should be set when the context is
-- constant indexing.
+ -----------------------------
+ -- Expr_Matches_In_Formal --
+ -----------------------------
+
+ function Expr_Matches_In_Formal
+ (Subp : Entity_Id;
+ Par : Node_Id) return Boolean
+ is
+ Actual : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ Formal := First_Formal (Subp);
+ Actual := First (Parameter_Associations ((Parent (Par))));
+
+ if Nkind (Par) /= N_Parameter_Association then
+
+ -- Match by position.
+
+ while Present (Actual) and then Present (Formal) loop
+ exit when Actual = Par;
+ Next (Actual);
+
+ if Present (Formal) then
+ Next_Formal (Formal);
+
+ -- Otherwise this is a parameter mismatch, the error is
+ -- reported elsewhere, or else variable indexing is implied.
+
+ else
+ return False;
+ end if;
+ end loop;
+
+ else
+ -- Match by name
+
+ while Present (Formal) loop
+ exit when Chars (Formal) = Chars (Selector_Name (Par));
+ Next_Formal (Formal);
+
+ if No (Formal) then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return Present (Formal) and then Ekind (Formal) = E_In_Parameter;
+ end Expr_Matches_In_Formal;
+
--------------------------
-- Constant_Indexing_OK --
--------------------------
@@ -7566,8 +7625,6 @@
and then Is_Entity_Name (Name (Parent (Par)))
then
declare
- Actual : Node_Id;
- Formal : Entity_Id;
Proc : Entity_Id;
begin
@@ -7582,34 +7639,22 @@
if Is_Overloaded (Name (Parent (Par))) then
declare
Proc : constant Node_Id := Name (Parent (Par));
- A : Node_Id;
- F : Entity_Id;
I : Interp_Index;
It : Interp;
begin
Get_First_Interp (Proc, I, It);
while Present (It.Nam) loop
- F := First_Formal (It.Nam);
- A := First (Parameter_Associations (Parent (Par)));
+ if not Expr_Matches_In_Formal (It.Nam, Par) then
+ return False;
+ end if;
- while Present (F) and then Present (A) loop
- if A = Par then
- if Ekind (F) /= E_In_Parameter then
- return False;
- else
- exit; -- interpretation is safe
- end if;
- end if;
-
- Next_Formal (F);
- Next_Actual (A);
- end loop;
-
Get_Next_Interp (I, It);
end loop;
end;
+ -- All interpretations have a matching in-formal.
+
return True;
else
@@ -7623,27 +7668,7 @@
end if;
end if;
- Formal := First_Formal (Proc);
- Actual := First_Actual (Parent (Par));
-
- -- Find corresponding actual
-
- while Present (Actual) loop
- exit when Actual = Par;
- Next_Actual (Actual);
-
- if Present (Formal) then
- Next_Formal (Formal);
-
- -- Otherwise this is a parameter mismatch, the error is
- -- reported elsewhere.
-
- else
- return False;
- end if;
- end loop;
-
- return Ekind (Formal) = E_In_Parameter;
+ return Expr_Matches_In_Formal (Proc, Par);
end;
elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then
This patch fixes a spurious error on a user-defined indexing that appears as the actual in a parameter association of a procedure call. Given that the enclosing call has not been analyzed yet, determining the matching formal of the candidate subprogram must be located by name and not by position. The following must compile quietly: --- with Ada.Containers.Ordered_Maps; procedure Bug_Test is package Quoting is type Quoting_Order_Data_Type is null record; type Quoting_Order_Type is access Quoting_Order_Data_Type; procedure Update_Settings (Parameter : Boolean; Quoting_Order : in out Quoting_Order_Type ); end Quoting; package body Quoting is procedure Update_Settings (Parameter : Boolean; Quoting_Order : in out Quoting_Order_Type ) is begin null; end Update_Settings; end Quoting; package Data_Maps is new Ada.Containers.Ordered_Maps(Key_Type => Integer, Element_Type => Quoting.Quoting_Order_Type, "<" => "<", "=" => Quoting."="); Q_Order : constant Quoting.Quoting_Order_Type := new Quoting.Quoting_Order_Data_Type; Data_Map : Data_Maps.Map := Data_Maps.Empty_Map; begin Data_Map.Insert(1, Q_Order); Quoting.Update_Settings(Parameter => False, Quoting_Order => Data_Map (1)); Quoting.Update_Settings(Quoting_Order => Data_Map (1), Parameter => False); Quoting.Update_Settings(False, Data_Map (1)); end Bug_Test; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-04-25 Ed Schonberg <schonberg@adacore.com> * sem_ch4.adb (Try_Container_Indexing): Handle properly a container indexing operation that appears as a an actual in a parameter association in a procedure call.