Skip to content

R
riscv-gcc-1
Commit 4c46b835 by Arnaud Charlet
Options

[multiple changes] 

2004-08-16  Pascal Obry  <obry@gnat.com>

	* adaint.c (__gnat_prj_add_obj_files): Set to 0 only on Win32 for GCC
	backend prior to GCC 3.4. With GCC 3.4 we are using the GCC's shared
	option and not mdll anymore. Update comment.

2004-08-16  Pascal Obry  <obry@gnat.com>

	* bld.adb (Put_Include_Project): Properly handle directory separators
	on Windows.

2004-08-16  Ed Schonberg  <schonberg@gnat.com>

	* sem_ch4.adb (Try_Object_Operation): Restructure code. Optimize by
	decreasing the number of allocated junk nodes while searching for the
	appropriate subprogram.

From-SVN: r86049
parent 16e9be4c
Showing with 399 additions and 314 deletions
gcc/ada/ChangeLog
2004-08-16 Pascal Obry <obry@gnat.com>
* adaint.c (__gnat_prj_add_obj_files): Set to 0 only on Win32 for GCC
backend prior to GCC 3.4. With GCC 3.4 we are using the GCC's shared
option and not mdll anymore. Update comment.
2004-08-16 Pascal Obry <obry@gnat.com>
* bld.adb (Put_Include_Project): Properly handle directory separators
on Windows.
2004-08-16 Ed Schonberg <schonberg@gnat.com>
* sem_ch4.adb (Try_Object_Operation): Restructure code. Optimize by
decreasing the number of allocated junk nodes while searching for the
appropriate subprogram.
2004-08-15 Nathan Sidwell <nathan@codesourcery.com> 2004-08-15 Nathan Sidwell <nathan@codesourcery.com>
* cuintp.c (UI_To_gnu): Use build_int_cst.. * cuintp.c (UI_To_gnu): Use build_int_cst..
......
gcc/ada/adaint.c
...@@ -2469,8 +2469,11 @@ int __gnat_argument_needs_quote = 0; ...@@ -2469,8 +2469,11 @@ int __gnat_argument_needs_quote = 0;
/* This option is used to enable/disable object files handling from the /* This option is used to enable/disable object files handling from the
binder file by the GNAT Project module. For example, this is disabled on binder file by the GNAT Project module. For example, this is disabled on
Windows as it is already done by the mdll module. */ Windows (prior to GCC 3.4) as it is already done by the mdll module.
#if defined (_WIN32) Stating with GCC 3.4 the shared libraries are not based on mdll
anymore as it uses the GCC's -shared option */
#if defined (_WIN32) \
&& ((__GNUC__ < 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ < 4)))
int __gnat_prj_add_obj_files = 0; int __gnat_prj_add_obj_files = 0;
#else #else
int __gnat_prj_add_obj_files = 1; int __gnat_prj_add_obj_files = 1;
......
gcc/ada/bld.adb
...@@ -2388,7 +2388,8 @@ package body Bld is ...@@ -2388,7 +2388,8 @@ package body Bld is
-- directory. -- directory.
if Last >= Included_Directory_Path'First if Last >= Included_Directory_Path'First
and then Included_Directory_Path (Last) = Directory_Separator and then (Included_Directory_Path (Last) = Directory_Separator
or else Included_Directory_Path (Last) = '/')
then then
Last := Last - 1; Last := Last - 1;
end if; end if;
......
gcc/ada/sem_ch4.adb
...@@ -244,6 +244,10 @@ package body Sem_Ch4 is ...@@ -244,6 +244,10 @@ package body Sem_Ch4 is
procedure Ambiguous_Operands (N : Node_Id) is procedure Ambiguous_Operands (N : Node_Id) is
procedure List_Operand_Interps (Opnd : Node_Id); procedure List_Operand_Interps (Opnd : Node_Id);
--------------------------
-- List_Operand_Interps --
--------------------------
procedure List_Operand_Interps (Opnd : Node_Id) is procedure List_Operand_Interps (Opnd : Node_Id) is
Nam : Node_Id; Nam : Node_Id;
Err : Node_Id := N; Err : Node_Id := N;
...@@ -252,10 +256,8 @@ package body Sem_Ch4 is ...@@ -252,10 +256,8 @@ package body Sem_Ch4 is
if Is_Overloaded (Opnd) then if Is_Overloaded (Opnd) then
if Nkind (Opnd) in N_Op then if Nkind (Opnd) in N_Op then
Nam := Opnd; Nam := Opnd;
elsif Nkind (Opnd) = N_Function_Call then elsif Nkind (Opnd) = N_Function_Call then
Nam := Name (Opnd); Nam := Name (Opnd);
else else
return; return;
end if; end if;
...@@ -276,6 +278,8 @@ package body Sem_Ch4 is ...@@ -276,6 +278,8 @@ package body Sem_Ch4 is
List_Interps (Nam, Err); List_Interps (Nam, Err);
end List_Operand_Interps; end List_Operand_Interps;
-- Start of processing for Ambiguous_Operands
begin begin
if Nkind (N) = N_In if Nkind (N) = N_In
or else Nkind (N) = N_Not_In or else Nkind (N) = N_Not_In
...@@ -373,6 +377,8 @@ package body Sem_Ch4 is ...@@ -373,6 +377,8 @@ package body Sem_Ch4 is
Set_Etype (E, Type_Id); Set_Etype (E, Type_Id);
-- Case where no qualified expression is present
else else
declare declare
Def_Id : Entity_Id; Def_Id : Entity_Id;
...@@ -586,12 +592,12 @@ package body Sem_Ch4 is ...@@ -586,12 +592,12 @@ package body Sem_Ch4 is
-- Analyze_Call -- -- Analyze_Call --
------------------ ------------------
-- Function, procedure, and entry calls are checked here. The Name -- Function, procedure, and entry calls are checked here. The Name in
-- in the call may be overloaded. The actuals have been analyzed -- the call may be overloaded. The actuals have been analyzed and may
-- and may themselves be overloaded. On exit from this procedure, the node -- themselves be overloaded. On exit from this procedure, the node N
-- N may have zero, one or more interpretations. In the first case an error -- may have zero, one or more interpretations. In the first case an
-- message is produced. In the last case, the node is flagged as overloaded -- error message is produced. In the last case, the node is flagged
-- and the interpretations are collected in All_Interp. -- as overloaded and the interpretations are collected in All_Interp.
-- If the name is an Access_To_Subprogram, it cannot be overloaded, but -- If the name is an Access_To_Subprogram, it cannot be overloaded, but
-- the type-checking is similar to that of other calls. -- the type-checking is similar to that of other calls.
...@@ -675,12 +681,10 @@ package body Sem_Ch4 is ...@@ -675,12 +681,10 @@ package body Sem_Ch4 is
if Nkind (Prefix (Nam)) = N_Selected_Component then if Nkind (Prefix (Nam)) = N_Selected_Component then
Nam_Ent := Entity (Selector_Name (Prefix (Nam))); Nam_Ent := Entity (Selector_Name (Prefix (Nam)));
else else
Error_Msg_N ("name in call is not a callable entity", Nam); Error_Msg_N ("name in call is not a callable entity", Nam);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
return; return;
end if; end if;
elsif not Is_Entity_Name (Nam) then elsif not Is_Entity_Name (Nam) then
...@@ -887,7 +891,6 @@ package body Sem_Ch4 is ...@@ -887,7 +891,6 @@ package body Sem_Ch4 is
Analyze_Expression (R); Analyze_Expression (R);
if Present (Op_Id) then if Present (Op_Id) then
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Find_Comparison_Types (L, R, Op_Id, N); Find_Comparison_Types (L, R, Op_Id, N);
else else
...@@ -900,9 +903,7 @@ package body Sem_Ch4 is ...@@ -900,9 +903,7 @@ package body Sem_Ch4 is
else else
Op_Id := Get_Name_Entity_Id (Chars (N)); Op_Id := Get_Name_Entity_Id (Chars (N));
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Find_Comparison_Types (L, R, Op_Id, N); Find_Comparison_Types (L, R, Op_Id, N);
else else
...@@ -982,11 +983,10 @@ package body Sem_Ch4 is ...@@ -982,11 +983,10 @@ package body Sem_Ch4 is
Add_One_Interp (N, Op_Id, Etype (Op_Id)); Add_One_Interp (N, Op_Id, Etype (Op_Id));
else else
-- Type and its operations must be visible. -- Type and its operations must be visible
Set_Entity (N, Empty); Set_Entity (N, Empty);
Analyze_Concatenation (N); Analyze_Concatenation (N);
end if; end if;
else else
...@@ -995,7 +995,6 @@ package body Sem_Ch4 is ...@@ -995,7 +995,6 @@ package body Sem_Ch4 is
else else
Op_Id := Get_Name_Entity_Id (Name_Op_Concat); Op_Id := Get_Name_Entity_Id (Name_Op_Concat);
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Find_Concatenation_Types (L, R, Op_Id, N); Find_Concatenation_Types (L, R, Op_Id, N);
...@@ -1018,7 +1017,6 @@ package body Sem_Ch4 is ...@@ -1018,7 +1017,6 @@ package body Sem_Ch4 is
Condition : constant Node_Id := First (Expressions (N)); Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition); Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr); Else_Expr : constant Node_Id := Next (Then_Expr);
begin begin
Analyze_Expression (Condition); Analyze_Expression (Condition);
Analyze_Expression (Then_Expr); Analyze_Expression (Then_Expr);
...@@ -1055,7 +1053,6 @@ package body Sem_Ch4 is ...@@ -1055,7 +1053,6 @@ package body Sem_Ch4 is
-- of the user-defined function. -- of the user-defined function.
if Present (Entity (N)) then if Present (Entity (N)) then
Op_Id := Entity (N); Op_Id := Entity (N);
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
...@@ -1065,7 +1062,6 @@ package body Sem_Ch4 is ...@@ -1065,7 +1062,6 @@ package body Sem_Ch4 is
end if; end if;
if Is_Overloaded (L) then if Is_Overloaded (L) then
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Set_Etype (L, Intersect_Types (L, R)); Set_Etype (L, Intersect_Types (L, R));
else else
...@@ -1075,9 +1071,7 @@ package body Sem_Ch4 is ...@@ -1075,9 +1071,7 @@ package body Sem_Ch4 is
else else
Op_Id := Get_Name_Entity_Id (Chars (N)); Op_Id := Get_Name_Entity_Id (Chars (N));
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Find_Equality_Types (L, R, Op_Id, N); Find_Equality_Types (L, R, Op_Id, N);
else else
...@@ -1141,7 +1135,11 @@ package body Sem_Ch4 is ...@@ -1141,7 +1135,11 @@ package body Sem_Ch4 is
New_N : Node_Id; New_N : Node_Id;
function Is_Function_Type return Boolean; function Is_Function_Type return Boolean;
-- Check whether node may be interpreted as an implicit function call. -- Check whether node may be interpreted as an implicit function call
----------------------
-- Is_Function_Type --
----------------------
function Is_Function_Type return Boolean is function Is_Function_Type return Boolean is
I : Interp_Index; I : Interp_Index;
...@@ -1169,6 +1167,8 @@ package body Sem_Ch4 is ...@@ -1169,6 +1167,8 @@ package body Sem_Ch4 is
end if; end if;
end Is_Function_Type; end Is_Function_Type;
-- Start of processing for Analyze_Explicit_Deference
begin begin
Analyze (P); Analyze (P);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
...@@ -1266,7 +1266,6 @@ package body Sem_Ch4 is ...@@ -1266,7 +1266,6 @@ package body Sem_Ch4 is
if Is_Overloaded (P) then if Is_Overloaded (P) then
Get_First_Interp (P, I, It); Get_First_Interp (P, I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
T := It.Typ; T := It.Typ;
...@@ -1288,7 +1287,6 @@ package body Sem_Ch4 is ...@@ -1288,7 +1287,6 @@ package body Sem_Ch4 is
-- (RM E.2.2(16)). -- (RM E.2.2(16)).
Validate_Remote_Access_To_Class_Wide_Type (N); Validate_Remote_Access_To_Class_Wide_Type (N);
end Analyze_Explicit_Dereference; end Analyze_Explicit_Dereference;
------------------------ ------------------------
...@@ -1342,8 +1340,8 @@ package body Sem_Ch4 is ...@@ -1342,8 +1340,8 @@ package body Sem_Ch4 is
Change_Node (N, N_Function_Call); Change_Node (N, N_Function_Call);
Set_Name (N, P); Set_Name (N, P);
Set_Parameter_Associations (N, Exprs); Set_Parameter_Associations (N, Exprs);
Actual := First (Parameter_Associations (N));
Actual := First (Parameter_Associations (N));
while Present (Actual) loop while Present (Actual) loop
Analyze (Actual); Analyze (Actual);
Check_Parameterless_Call (Actual); Check_Parameterless_Call (Actual);
...@@ -1476,7 +1474,6 @@ package body Sem_Ch4 is ...@@ -1476,7 +1474,6 @@ package body Sem_Ch4 is
Error_Msg_N ("too many subscripts in array reference", Exp); Error_Msg_N ("too many subscripts in array reference", Exp);
end if; end if;
end if; end if;
end Process_Indexed_Component; end Process_Indexed_Component;
---------------------------------------- ----------------------------------------
...@@ -1486,7 +1483,6 @@ package body Sem_Ch4 is ...@@ -1486,7 +1483,6 @@ package body Sem_Ch4 is
procedure Process_Indexed_Component_Or_Slice is procedure Process_Indexed_Component_Or_Slice is
begin begin
Exp := First (Exprs); Exp := First (Exprs);
while Present (Exp) loop while Present (Exp) loop
Analyze_Expression (Exp); Analyze_Expression (Exp);
Next (Exp); Next (Exp);
...@@ -1534,8 +1530,8 @@ package body Sem_Ch4 is ...@@ -1534,8 +1530,8 @@ package body Sem_Ch4 is
begin begin
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Get_First_Interp (P, I, It);
Get_First_Interp (P, I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
Typ := It.Typ; Typ := It.Typ;
...@@ -1550,9 +1546,7 @@ package body Sem_Ch4 is ...@@ -1550,9 +1546,7 @@ package body Sem_Ch4 is
Index := First_Index (Typ); Index := First_Index (Typ);
Found := True; Found := True;
Exp := First (Exprs); Exp := First (Exprs);
while Present (Index) and then Present (Exp) loop while Present (Index) and then Present (Exp) loop
if Has_Compatible_Type (Exp, Etype (Index)) then if Has_Compatible_Type (Exp, Etype (Index)) then
null; null;
...@@ -1584,9 +1578,7 @@ package body Sem_Ch4 is ...@@ -1584,9 +1578,7 @@ package body Sem_Ch4 is
End_Interp_List; End_Interp_List;
end Process_Overloaded_Indexed_Component; end Process_Overloaded_Indexed_Component;
------------------------------------ -- Start of processing for Analyze_Indexed_Component_Form
-- Analyze_Indexed_Component_Form --
------------------------------------
begin begin
-- Get name of array, function or type -- Get name of array, function or type
...@@ -1613,7 +1605,7 @@ package body Sem_Ch4 is ...@@ -1613,7 +1605,7 @@ package body Sem_Ch4 is
if Ekind (U_N) in Type_Kind then if Ekind (U_N) in Type_Kind then
-- Reformat node as a type conversion. -- Reformat node as a type conversion
E := Remove_Head (Exprs); E := Remove_Head (Exprs);
...@@ -1648,7 +1640,7 @@ package body Sem_Ch4 is ...@@ -1648,7 +1640,7 @@ package body Sem_Ch4 is
elsif Is_Generic_Subprogram (U_N) then elsif Is_Generic_Subprogram (U_N) then
-- A common beginner's (or C++ templates fan) error. -- A common beginner's (or C++ templates fan) error
Error_Msg_N ("generic subprogram cannot be called", N); Error_Msg_N ("generic subprogram cannot be called", N);
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
...@@ -1744,6 +1736,10 @@ package body Sem_Ch4 is ...@@ -1744,6 +1736,10 @@ package body Sem_Ch4 is
-- if there is more than one interpretation of the operands that is -- if there is more than one interpretation of the operands that is
-- compatible with a membership test, the operation is ambiguous. -- compatible with a membership test, the operation is ambiguous.
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is procedure Try_One_Interp (T1 : Entity_Id) is
begin begin
if Has_Compatible_Type (R, T1) then if Has_Compatible_Type (R, T1) then
...@@ -1836,7 +1832,6 @@ package body Sem_Ch4 is ...@@ -1836,7 +1832,6 @@ package body Sem_Ch4 is
else else
Op_Id := Get_Name_Entity_Id (Chars (N)); Op_Id := Get_Name_Entity_Id (Chars (N));
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
Find_Negation_Types (R, Op_Id, N); Find_Negation_Types (R, Op_Id, N);
...@@ -1970,7 +1965,7 @@ package body Sem_Ch4 is ...@@ -1970,7 +1965,7 @@ package body Sem_Ch4 is
then then
return; return;
-- Ditto for function calls in a procedure context. -- Ditto for function calls in a procedure context
elsif Nkind (N) = N_Procedure_Call_Statement elsif Nkind (N) = N_Procedure_Call_Statement
and then Is_Overloaded (Name (N)) and then Is_Overloaded (Name (N))
...@@ -2010,9 +2005,7 @@ package body Sem_Ch4 is ...@@ -2010,9 +2005,7 @@ package body Sem_Ch4 is
begin begin
Get_First_Interp (Name (N), I, It); Get_First_Interp (Name (N), I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Ekind (It.Nam) /= E_Operator if Ekind (It.Nam) /= E_Operator
and then Hides_Op (It.Nam, Nam) and then Hides_Op (It.Nam, Nam)
and then and then
...@@ -2050,9 +2043,7 @@ package body Sem_Ch4 is ...@@ -2050,9 +2043,7 @@ package body Sem_Ch4 is
Actual := First_Actual (N); Actual := First_Actual (N);
Formal := First_Formal (Nam); Formal := First_Formal (Nam);
while Present (Actual) and then Present (Formal) loop while Present (Actual) and then Present (Formal) loop
if Nkind (Parent (Actual)) /= N_Parameter_Association if Nkind (Parent (Actual)) /= N_Parameter_Association
or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal) or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
then then
...@@ -2072,7 +2063,6 @@ package body Sem_Ch4 is ...@@ -2072,7 +2063,6 @@ package body Sem_Ch4 is
end if; end if;
if Report and not Is_Indexed then if Report and not Is_Indexed then
Wrong_Type (Actual, Etype (Formal)); Wrong_Type (Actual, Etype (Formal));
if Nkind (Actual) = N_Op_Eq if Nkind (Actual) = N_Op_Eq
...@@ -2132,7 +2122,7 @@ package body Sem_Ch4 is ...@@ -2132,7 +2122,7 @@ package body Sem_Ch4 is
end if; end if;
end loop; end loop;
-- On exit, all actuals match. -- On exit, all actuals match
Indicate_Name_And_Type; Indicate_Name_And_Type;
end if; end if;
...@@ -2148,14 +2138,13 @@ package body Sem_Ch4 is ...@@ -2148,14 +2138,13 @@ package body Sem_Ch4 is
Act2 : constant Node_Id := Next_Actual (Act1); Act2 : constant Node_Id := Next_Actual (Act1);
begin begin
-- Binary operator case
if Present (Act2) then if Present (Act2) then
-- Maybe binary operators -- If more than two operands, then not binary operator after all
if Present (Next_Actual (Act2)) then if Present (Next_Actual (Act2)) then
-- Too many actuals for an operator
return; return;
elsif Op_Name = Name_Op_Add elsif Op_Name = Name_Op_Add
...@@ -2195,9 +2184,9 @@ package body Sem_Ch4 is ...@@ -2195,9 +2184,9 @@ package body Sem_Ch4 is
null; null;
end if; end if;
else -- Unary operator case
-- Unary operators
else
if Op_Name = Name_Op_Subtract or else if Op_Name = Name_Op_Subtract or else
Op_Name = Name_Op_Add or else Op_Name = Name_Op_Add or else
Op_Name = Name_Op_Abs Op_Name = Name_Op_Abs
...@@ -2230,24 +2219,20 @@ package body Sem_Ch4 is ...@@ -2230,24 +2219,20 @@ package body Sem_Ch4 is
T : Entity_Id; T : Entity_Id;
begin begin
Get_First_Interp (Nam, I, It);
Set_Etype (Sel, Any_Type); Set_Etype (Sel, Any_Type);
Get_First_Interp (Nam, I, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Is_Access_Type (It.Typ) then if Is_Access_Type (It.Typ) then
T := Designated_Type (It.Typ); T := Designated_Type (It.Typ);
Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N); Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
else else
T := It.Typ; T := It.Typ;
end if; end if;
if Is_Record_Type (T) then if Is_Record_Type (T) then
Comp := First_Entity (T); Comp := First_Entity (T);
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Chars (Sel) if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp) and then Is_Visible_Component (Comp)
then then
...@@ -2268,7 +2253,6 @@ package body Sem_Ch4 is ...@@ -2268,7 +2253,6 @@ package body Sem_Ch4 is
elsif Is_Concurrent_Type (T) then elsif Is_Concurrent_Type (T) then
Comp := First_Entity (T); Comp := First_Entity (T);
while Present (Comp) while Present (Comp)
and then Comp /= First_Private_Entity (T) and then Comp /= First_Private_Entity (T)
loop loop
...@@ -2308,7 +2292,6 @@ package body Sem_Ch4 is ...@@ -2308,7 +2292,6 @@ package body Sem_Ch4 is
Set_Entity (Sel, Any_Id); Set_Entity (Sel, Any_Id);
Set_Etype (Sel, Any_Type); Set_Etype (Sel, Any_Type);
end if; end if;
end Analyze_Overloaded_Selected_Component; end Analyze_Overloaded_Selected_Component;
---------------------------------- ----------------------------------
...@@ -2327,8 +2310,8 @@ package body Sem_Ch4 is ...@@ -2327,8 +2310,8 @@ package body Sem_Ch4 is
if T = Any_Type then if T = Any_Type then
return; return;
end if; end if;
Check_Fully_Declared (T, N);
Check_Fully_Declared (T, N);
Analyze_Expression (Expression (N)); Analyze_Expression (Expression (N));
Set_Etype (N, T); Set_Etype (N, T);
end Analyze_Qualified_Expression; end Analyze_Qualified_Expression;
...@@ -2387,7 +2370,6 @@ package body Sem_Ch4 is ...@@ -2387,7 +2370,6 @@ package body Sem_Ch4 is
Check_Common_Type (T, Etype (H)); Check_Common_Type (T, Etype (H));
else else
Get_First_Interp (H, I2, It2); Get_First_Interp (H, I2, It2);
while Present (It2.Typ) loop while Present (It2.Typ) loop
Check_Common_Type (T, It2.Typ); Check_Common_Type (T, It2.Typ);
Get_Next_Interp (I2, It2); Get_Next_Interp (I2, It2);
...@@ -2425,7 +2407,6 @@ package body Sem_Ch4 is ...@@ -2425,7 +2407,6 @@ package body Sem_Ch4 is
Check_High_Bound (Etype (L)); Check_High_Bound (Etype (L));
else else
Get_First_Interp (L, I1, It1); Get_First_Interp (L, I1, It1);
while Present (It1.Typ) loop while Present (It1.Typ) loop
Check_High_Bound (It1.Typ); Check_High_Bound (It1.Typ);
Get_Next_Interp (I1, It1); Get_Next_Interp (I1, It1);
...@@ -2456,7 +2437,6 @@ package body Sem_Ch4 is ...@@ -2456,7 +2437,6 @@ package body Sem_Ch4 is
procedure Analyze_Reference (N : Node_Id) is procedure Analyze_Reference (N : Node_Id) is
P : constant Node_Id := Prefix (N); P : constant Node_Id := Prefix (N);
Acc_Type : Entity_Id; Acc_Type : Entity_Id;
begin begin
Analyze (P); Analyze (P);
Acc_Type := Create_Itype (E_Allocator_Type, N); Acc_Type := Create_Itype (E_Allocator_Type, N);
...@@ -2580,7 +2560,6 @@ package body Sem_Ch4 is ...@@ -2580,7 +2560,6 @@ package body Sem_Ch4 is
-- Find component with given name -- Find component with given name
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Chars (Sel) if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp) and then Is_Visible_Component (Comp)
then then
...@@ -2688,6 +2667,11 @@ package body Sem_Ch4 is ...@@ -2688,6 +2667,11 @@ package body Sem_Ch4 is
and then Try_Object_Operation (N) and then Try_Object_Operation (N)
then then
return; return;
-- If the transformation fails, it will be necessary
-- to redo the analysis with all errors enabled, to indicate
-- candidate interpretations and reasons for each failure ???
end if; end if;
elsif Is_Private_Type (Prefix_Type) then elsif Is_Private_Type (Prefix_Type) then
...@@ -2702,7 +2686,6 @@ package body Sem_Ch4 is ...@@ -2702,7 +2686,6 @@ package body Sem_Ch4 is
end if; end if;
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Chars (Sel) then if Chars (Comp) = Chars (Sel) then
if Ekind (Comp) = E_Discriminant then if Ekind (Comp) = E_Discriminant then
Set_Entity_With_Style_Check (Sel, Comp); Set_Entity_With_Style_Check (Sel, Comp);
...@@ -2793,7 +2776,7 @@ package body Sem_Ch4 is ...@@ -2793,7 +2776,7 @@ package body Sem_Ch4 is
Error_Msg_NE ("invalid prefix in selected component&", N, Sel); Error_Msg_NE ("invalid prefix in selected component&", N, Sel);
end if; end if;
-- If N still has no type, the component is not defined in the prefix. -- If N still has no type, the component is not defined in the prefix
if Etype (N) = Any_Type then if Etype (N) = Any_Type then
...@@ -2828,17 +2811,16 @@ package body Sem_Ch4 is ...@@ -2828,17 +2811,16 @@ package body Sem_Ch4 is
and then Is_Generic_Actual_Type (Prefix_Type) and then Is_Generic_Actual_Type (Prefix_Type)
and then Present (Full_View (Prefix_Type)) and then Present (Full_View (Prefix_Type))
then then
-- Similarly, if this the actual for a formal derived type, -- Similarly, if this the actual for a formal derived type, the
-- the component inherited from the generic parent may not -- component inherited from the generic parent may not be visible
-- be visible in the actual, but the selected component is -- in the actual, but the selected component is legal.
-- legal.
declare declare
Comp : Entity_Id; Comp : Entity_Id;
begin begin
Comp := Comp :=
First_Component (Generic_Parent_Type (Parent (Prefix_Type))); First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Chars (Sel) then if Chars (Comp) = Chars (Sel) then
Set_Entity_With_Style_Check (Sel, Comp); Set_Entity_With_Style_Check (Sel, Comp);
...@@ -2864,9 +2846,7 @@ package body Sem_Ch4 is ...@@ -2864,9 +2846,7 @@ package body Sem_Ch4 is
-- compilation error anyway. -- compilation error anyway.
Comp := First_Component (Base_Type (Prefix_Type)); Comp := First_Component (Base_Type (Prefix_Type));
while Present (Comp) loop while Present (Comp) loop
if Chars (Comp) = Chars (Sel) if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp) and then Is_Visible_Component (Comp)
then then
...@@ -2968,6 +2948,10 @@ package body Sem_Ch4 is ...@@ -2968,6 +2948,10 @@ package body Sem_Ch4 is
-- If the prefix is overloaded, select those interpretations that -- If the prefix is overloaded, select those interpretations that
-- yield a one-dimensional array type. -- yield a one-dimensional array type.
------------------------------
-- Analyze_Overloaded_Slice --
------------------------------
procedure Analyze_Overloaded_Slice is procedure Analyze_Overloaded_Slice is
I : Interp_Index; I : Interp_Index;
It : Interp; It : Interp;
...@@ -2975,8 +2959,8 @@ package body Sem_Ch4 is ...@@ -2975,8 +2959,8 @@ package body Sem_Ch4 is
begin begin
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Get_First_Interp (P, I, It);
Get_First_Interp (P, I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
Typ := It.Typ; Typ := It.Typ;
...@@ -3003,7 +2987,6 @@ package body Sem_Ch4 is ...@@ -3003,7 +2987,6 @@ package body Sem_Ch4 is
-- Start of processing for Analyze_Slice -- Start of processing for Analyze_Slice
begin begin
Analyze (P); Analyze (P);
Analyze (D); Analyze (D);
...@@ -3108,7 +3091,6 @@ package body Sem_Ch4 is ...@@ -3108,7 +3091,6 @@ package body Sem_Ch4 is
Error_Msg_N ("argument of conversion cannot be access", N); Error_Msg_N ("argument of conversion cannot be access", N);
Error_Msg_N ("\use qualified expression instead", N); Error_Msg_N ("\use qualified expression instead", N);
end if; end if;
end Analyze_Type_Conversion; end Analyze_Type_Conversion;
---------------------- ----------------------
...@@ -3134,9 +3116,7 @@ package body Sem_Ch4 is ...@@ -3134,9 +3116,7 @@ package body Sem_Ch4 is
else else
Op_Id := Get_Name_Entity_Id (Chars (N)); Op_Id := Get_Name_Entity_Id (Chars (N));
while Present (Op_Id) loop while Present (Op_Id) loop
if Ekind (Op_Id) = E_Operator then if Ekind (Op_Id) = E_Operator then
if No (Next_Entity (First_Entity (Op_Id))) then if No (Next_Entity (First_Entity (Op_Id))) then
Find_Unary_Types (R, Op_Id, N); Find_Unary_Types (R, Op_Id, N);
...@@ -3267,6 +3247,10 @@ package body Sem_Ch4 is ...@@ -3267,6 +3247,10 @@ package body Sem_Ch4 is
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id; function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
-- Get specific type (i.e. non-universal type if there is one) -- Get specific type (i.e. non-universal type if there is one)
-------------------
-- Specific_Type --
-------------------
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is function Specific_Type (T1, T2 : Entity_Id) return Entity_Id is
begin begin
if T1 = Universal_Integer or else T1 = Universal_Real then if T1 = Universal_Integer or else T1 = Universal_Real then
...@@ -3367,7 +3351,6 @@ package body Sem_Ch4 is ...@@ -3367,7 +3351,6 @@ package body Sem_Ch4 is
end if; end if;
elsif Op_Name = Name_Op_Expon then elsif Op_Name = Name_Op_Expon then
if Is_Numeric_Type (T1) if Is_Numeric_Type (T1)
and then not Is_Fixed_Point_Type (T1) and then not Is_Fixed_Point_Type (T1)
and then (Base_Type (T2) = Base_Type (Standard_Integer) and then (Base_Type (T2) = Base_Type (Standard_Integer)
...@@ -3414,24 +3397,23 @@ package body Sem_Ch4 is ...@@ -3414,24 +3397,23 @@ package body Sem_Ch4 is
-- possible misspellings, these misspellings will be suggested as -- possible misspellings, these misspellings will be suggested as
-- possible correction. -- possible correction.
if not (Is_Private_Type (Prefix) or Is_Record_Type (Prefix)) then if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
-- Concurrent types should be handled as well ??? -- Concurrent types should be handled as well ???
return; return;
end if; end if;
Get_Name_String (Chars (Sel)); Get_Name_String (Chars (Sel));
declare declare
S : constant String (1 .. Name_Len) := S : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. Name_Len);
begin begin
Comp := First_Entity (Prefix); Comp := First_Entity (Prefix);
while Nr_Of_Suggestions <= Max_Suggestions while Nr_Of_Suggestions <= Max_Suggestions
and then Present (Comp) and then Present (Comp)
loop loop
if Is_Visible_Component (Comp) then if Is_Visible_Component (Comp) then
Get_Name_String (Chars (Comp)); Get_Name_String (Chars (Comp));
...@@ -3469,7 +3451,6 @@ package body Sem_Ch4 is ...@@ -3469,7 +3451,6 @@ package body Sem_Ch4 is
function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean function Defined_In_Scope (T : Entity_Id; S : Entity_Id) return Boolean
is is
S1 : constant Entity_Id := Scope (Base_Type (T)); S1 : constant Entity_Id := Scope (Base_Type (T));
begin begin
return S1 = S return S1 = S
or else (S1 = System_Aux_Id and then S = Scope (S1)); or else (S1 = System_Aux_Id and then S = Scope (S1));
...@@ -3545,7 +3526,6 @@ package body Sem_Ch4 is ...@@ -3545,7 +3526,6 @@ package body Sem_Ch4 is
if Nkind (N) = N_Function_Call then if Nkind (N) = N_Function_Call then
Get_First_Interp (Nam, X, It); Get_First_Interp (Nam, X, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Ekind (It.Nam) = E_Function if Ekind (It.Nam) = E_Function
or else Ekind (It.Nam) = E_Operator or else Ekind (It.Nam) = E_Operator
...@@ -3560,8 +3540,8 @@ package body Sem_Ch4 is ...@@ -3560,8 +3540,8 @@ package body Sem_Ch4 is
-- more precise message. Ditto if this appears as the prefix -- more precise message. Ditto if this appears as the prefix
-- of a selected component, which may be a lexical error. -- of a selected component, which may be a lexical error.
Error_Msg_N ( Error_Msg_N
"\context requires function call, found procedure name", Nam); ("\context requires function call, found procedure name", Nam);
if Nkind (Parent (N)) = N_Selected_Component if Nkind (Parent (N)) = N_Selected_Component
and then N = Prefix (Parent (N)) and then N = Prefix (Parent (N))
...@@ -3589,19 +3569,24 @@ package body Sem_Ch4 is ...@@ -3589,19 +3569,24 @@ package body Sem_Ch4 is
Op_Id : Entity_Id; Op_Id : Entity_Id;
N : Node_Id) N : Node_Id)
is is
Index1, Index2 : Interp_Index; Index1 : Interp_Index;
It1, It2 : Interp; Index2 : Interp_Index;
It1 : Interp;
It2 : Interp;
procedure Check_Right_Argument (T : Entity_Id); procedure Check_Right_Argument (T : Entity_Id);
-- Check right operand of operator -- Check right operand of operator
--------------------------
-- Check_Right_Argument --
--------------------------
procedure Check_Right_Argument (T : Entity_Id) is procedure Check_Right_Argument (T : Entity_Id) is
begin begin
if not Is_Overloaded (R) then if not Is_Overloaded (R) then
Check_Arithmetic_Pair (T, Etype (R), Op_Id, N); Check_Arithmetic_Pair (T, Etype (R), Op_Id, N);
else else
Get_First_Interp (R, Index2, It2); Get_First_Interp (R, Index2, It2);
while Present (It2.Typ) loop while Present (It2.Typ) loop
Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N); Check_Arithmetic_Pair (T, It2.Typ, Op_Id, N);
Get_Next_Interp (Index2, It2); Get_Next_Interp (Index2, It2);
...@@ -3642,6 +3627,10 @@ package body Sem_Ch4 is ...@@ -3642,6 +3627,10 @@ package body Sem_Ch4 is
-- Special case for logical operations one of whose operands is an -- Special case for logical operations one of whose operands is an
-- integer literal. If both are literal the result is any modular type. -- integer literal. If both are literal the result is any modular type.
----------------------------
-- Check_Numeric_Argument --
----------------------------
procedure Check_Numeric_Argument (T : Entity_Id) is procedure Check_Numeric_Argument (T : Entity_Id) is
begin begin
if T = Universal_Integer then if T = Universal_Integer then
...@@ -3656,7 +3645,6 @@ package body Sem_Ch4 is ...@@ -3656,7 +3645,6 @@ package body Sem_Ch4 is
begin begin
if not Is_Overloaded (L) then if not Is_Overloaded (L) then
if Etype (L) = Universal_Integer if Etype (L) = Universal_Integer
or else Etype (L) = Any_Modular or else Etype (L) = Any_Modular
then then
...@@ -3665,10 +3653,8 @@ package body Sem_Ch4 is ...@@ -3665,10 +3653,8 @@ package body Sem_Ch4 is
else else
Get_First_Interp (R, Index, It); Get_First_Interp (R, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
Check_Numeric_Argument (It.Typ); Check_Numeric_Argument (It.Typ);
Get_Next_Interp (Index, It); Get_Next_Interp (Index, It);
end loop; end loop;
end if; end if;
...@@ -3681,7 +3667,6 @@ package body Sem_Ch4 is ...@@ -3681,7 +3667,6 @@ package body Sem_Ch4 is
else else
Get_First_Interp (L, Index, It); Get_First_Interp (L, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Valid_Boolean_Arg (It.Typ) if Valid_Boolean_Arg (It.Typ)
and then Has_Compatible_Type (R, It.Typ) and then Has_Compatible_Type (R, It.Typ)
...@@ -3716,6 +3701,10 @@ package body Sem_Ch4 is ...@@ -3716,6 +3701,10 @@ package body Sem_Ch4 is
-- if there is more than one interpretation of the operands that is -- if there is more than one interpretation of the operands that is
-- compatible with comparison, the operation is ambiguous. -- compatible with comparison, the operation is ambiguous.
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is procedure Try_One_Interp (T1 : Entity_Id) is
begin begin
...@@ -3796,7 +3785,6 @@ package body Sem_Ch4 is ...@@ -3796,7 +3785,6 @@ package body Sem_Ch4 is
else else
Get_First_Interp (L, Index, It); Get_First_Interp (L, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
Try_One_Interp (It.Typ); Try_One_Interp (It.Typ);
Get_Next_Interp (Index, It); Get_Next_Interp (Index, It);
...@@ -3826,7 +3814,6 @@ package body Sem_Ch4 is ...@@ -3826,7 +3814,6 @@ package body Sem_Ch4 is
(N, Op_Id, Standard_Boolean, Base_Type (Etype (R))); (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
else else
Get_First_Interp (R, Index, It); Get_First_Interp (R, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Covers (It.Typ, T1) then if Covers (It.Typ, T1) then
Add_One_Interp Add_One_Interp
...@@ -3891,9 +3878,12 @@ package body Sem_Ch4 is ...@@ -3891,9 +3878,12 @@ package body Sem_Ch4 is
-- is ambiguous and an error can be emitted now, after trying to -- is ambiguous and an error can be emitted now, after trying to
-- disambiguate, i.e. applying preference rules. -- disambiguate, i.e. applying preference rules.
--------------------
-- Try_One_Interp --
--------------------
procedure Try_One_Interp (T1 : Entity_Id) is procedure Try_One_Interp (T1 : Entity_Id) is
begin begin
-- If the operator is an expanded name, then the type of the operand -- If the operator is an expanded name, then the type of the operand
-- must be defined in the corresponding scope. If the type is -- must be defined in the corresponding scope. If the type is
-- universal, the context will impose the correct type. An anonymous -- universal, the context will impose the correct type. An anonymous
...@@ -3993,10 +3983,9 @@ package body Sem_Ch4 is ...@@ -3993,10 +3983,9 @@ package body Sem_Ch4 is
if not Is_Overloaded (L) then if not Is_Overloaded (L) then
Try_One_Interp (Etype (L)); Try_One_Interp (Etype (L));
else
else
Get_First_Interp (L, Index, It); Get_First_Interp (L, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
Try_One_Interp (It.Typ); Try_One_Interp (It.Typ);
Get_Next_Interp (Index, It); Get_Next_Interp (Index, It);
...@@ -4018,17 +4007,14 @@ package body Sem_Ch4 is ...@@ -4018,17 +4007,14 @@ package body Sem_Ch4 is
begin begin
if not Is_Overloaded (R) then if not Is_Overloaded (R) then
if Etype (R) = Universal_Integer then if Etype (R) = Universal_Integer then
Add_One_Interp (N, Op_Id, Any_Modular); Add_One_Interp (N, Op_Id, Any_Modular);
elsif Valid_Boolean_Arg (Etype (R)) then elsif Valid_Boolean_Arg (Etype (R)) then
Add_One_Interp (N, Op_Id, Etype (R)); Add_One_Interp (N, Op_Id, Etype (R));
end if; end if;
else else
Get_First_Interp (R, Index, It); Get_First_Interp (R, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Valid_Boolean_Arg (It.Typ) then if Valid_Boolean_Arg (It.Typ) then
Add_One_Interp (N, Op_Id, It.Typ); Add_One_Interp (N, Op_Id, It.Typ);
...@@ -4059,7 +4045,6 @@ package body Sem_Ch4 is ...@@ -4059,7 +4045,6 @@ package body Sem_Ch4 is
else else
Get_First_Interp (R, Index, It); Get_First_Interp (R, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
if Is_Numeric_Type (It.Typ) then if Is_Numeric_Type (It.Typ) then
Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); Add_One_Interp (N, Op_Id, Base_Type (It.Typ));
...@@ -4184,14 +4169,13 @@ package body Sem_Ch4 is ...@@ -4184,14 +4169,13 @@ package body Sem_Ch4 is
then then
return; return;
-- We explicitly check for the case of concatenation of -- We explicitly check for the case of concatenation of component
-- component with component to avoid reporting spurious -- with component to avoid reporting spurious matching array types
-- matching array types that might happen to be lurking -- that might happen to be lurking in distant packages (such as
-- in distant packages (such as run-time packages). This -- run-time packages). This also prevents inconsistencies in the
-- also prevents inconsistencies in the messages for certain -- messages for certain ACVC B tests, which can vary depending on
-- ACVC B tests, which can vary depending on types declared -- types declared in run-time interfaces. Another improvement when
-- in run-time interfaces. A further improvement, when -- aggregates are present is to look for a well-typed operand.
-- aggregates are present, is to look for a well-typed operand.
elsif Present (Candidate_Type) elsif Present (Candidate_Type)
and then (Nkind (N) /= N_Op_Concat and then (Nkind (N) /= N_Op_Concat
...@@ -4432,6 +4416,7 @@ package body Sem_Ch4 is ...@@ -4432,6 +4416,7 @@ package body Sem_Ch4 is
return; return;
elsif Nkind (N) in N_Op then elsif Nkind (N) in N_Op then
-- Remove interpretations that treat literals as addresses. -- Remove interpretations that treat literals as addresses.
-- This is never appropriate. -- This is never appropriate.
...@@ -4645,7 +4630,6 @@ package body Sem_Ch4 is ...@@ -4645,7 +4630,6 @@ package body Sem_Ch4 is
else else
return False; return False;
end if; end if;
end Try_Indexed_Call; end Try_Indexed_Call;
-------------------------- --------------------------
...@@ -4653,148 +4637,238 @@ package body Sem_Ch4 is ...@@ -4653,148 +4637,238 @@ package body Sem_Ch4 is
-------------------------- --------------------------
function Try_Object_Operation (N : Node_Id) return Boolean is function Try_Object_Operation (N : Node_Id) return Boolean is
Loc : constant Source_Ptr := Sloc (N);
Obj : constant Node_Id := Prefix (N); Obj : constant Node_Id := Prefix (N);
Obj_Type : Entity_Id; Obj_Type : Entity_Id := Etype (Obj);
Actual : Node_Id; Subprog : constant Node_Id := Selector_Name (N);
Last_Node : Node_Id; Call_Node : Node_Id;
-- Used to free all the nodes generated while trying the alternatives. Call_Node_Case : Node_Id := Empty;
-- To me removed later, too low level ??? First_Actual : Node_Id;
Node_To_Replace : Node_Id;
use Atree_Private_Part; procedure Analyze_Actuals;
-- If the parent of N is a subprogram call, then analyze the actual
-- parameters of the parent of N.
function Try_Replacement procedure Complete_Object_Operation
(New_Prefix : Entity_Id; (Call_Node : Node_Id;
New_Subprg : Node_Id; Node_To_Replace : Node_Id;
New_Formal : Node_Id; Subprog : Node_Id);
Nam_Ent : Entity_Id) return Boolean; -- Set Subprog as the name of Call_Node, replace Node_To_Replace with
-- Replace the node with the Object.Operation notation by the -- Call_Node and reanalyze Node_To_Replace.
-- equivalent node with the Package.Operation (Object, ...) notation
-- procedure Transform_Object_Operation
-- Nam_Ent is the entity that provides the formals against which (Call_Node : out Node_Id;
-- the actuals are checked. If the actuals are compatible with First_Actual : Node_Id;
-- Ent_Nam, this function returns true. Node_To_Replace : out Node_Id;
-- Document other parameters, also what is Ent_Nam??? Subprog : Node_Id);
-- Transform Object.Operation (...) to Operation (Object, ...)
function Try_Primitive_Operations -- Call_Node is the resulting subprogram call node, First_Actual is
(New_Prefix : Entity_Id; -- either the object Obj or an explicit dereference of Obj in certain
New_Subprg : Node_Id; -- cases, Node_To_Replace is either N or the parent of N, and Subprog
Obj : Node_Id; -- is the subprogram we are trying to match.
Obj_Type : Entity_Id) return Boolean;
-- Traverse list of primitive subprograms to look for the subprogram
-- Parameters should be documented ???
-- subprogram.
function Try_Class_Wide_Operation function Try_Class_Wide_Operation
(New_Subprg : Node_Id; (Call_Node : Node_Id;
Obj : Node_Id; Node_To_Replace : Node_Id) return Boolean;
Obj_Type : Entity_Id) return Boolean; -- Traverse all the ancestor types looking for a class-wide subprogram
-- Traverse all the ancestor types to look for a class-wide subprogram -- that matches Subprog.
-- Parameters should be documented ???
------------------------------ function Try_Primitive_Operation
-- Try_Primitive_Operations -- (Call_Node : Node_Id;
------------------------------ Node_To_Replace : Node_Id) return Boolean;
-- Traverse the list of primitive subprograms looking for a subprogram
-- than matches Subprog.
function Try_Primitive_Operations ---------------------
(New_Prefix : Entity_Id; -- Analyze_Actuals --
New_Subprg : Node_Id; ---------------------
Obj : Node_Id;
Obj_Type : Entity_Id) return Boolean procedure Analyze_Actuals is
is Actual : Node_Id;
Deref : Node_Id;
Elmt : Elmt_Id;
Prim_Op : Entity_Id;
begin begin
-- Look for the subprogram in the list of primitive operations. if (Nkind (Parent (N)) = N_Procedure_Call_Statement
-- This case is simple because all the primitive operations are or else
-- implicitly inherited and thus we have a candidate as soon as Nkind (Parent (N)) = N_Function_Call)
-- we find a primitive subprogram with the same name. The latter
-- analysis after the node replacement will resolve it.
Elmt := First_Elmt (Primitive_Operations (Obj_Type)); -- Avoid recursive calls
while Present (Elmt) loop
Prim_Op := Node (Elmt);
if Chars (Prim_Op) = Chars (New_Subprg) then and then N /= First (Parameter_Associations (Parent (N)))
if Try_Replacement (New_Prefix => New_Prefix,
New_Subprg => New_Subprg,
New_Formal => Obj,
Nam_Ent => Prim_Op)
then then
return True; Actual := First (Parameter_Associations (Parent (N)));
while Present (Actual) loop
Analyze (Actual);
Check_Parameterless_Call (Actual);
Next (Actual);
-- Try the implicit dereference in case of access type end loop;
end if;
end Analyze_Actuals;
elsif Is_Access_Type (Etype (Obj)) then -------------------------------
Deref := Make_Explicit_Dereference (Sloc (Obj), Obj); -- Complete_Object_Operation --
Set_Etype (Deref, Obj_Type); -------------------------------
if Try_Replacement (New_Prefix => New_Prefix, procedure Complete_Object_Operation
New_Subprg => New_Subprg, (Call_Node : Node_Id;
New_Formal => Deref, Node_To_Replace : Node_Id;
Nam_Ent => Prim_Op) Subprog : Node_Id)
is
begin
Set_Name (Call_Node, New_Copy_Tree (Subprog));
Set_Analyzed (Call_Node, False);
Replace (Node_To_Replace, Call_Node);
Analyze (Node_To_Replace);
end Complete_Object_Operation;
--------------------------------
-- Transform_Object_Operation --
--------------------------------
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
First_Actual : Node_Id;
Node_To_Replace : out Node_Id;
Subprog : Node_Id)
is
Actuals : List_Id;
Parent_Node : constant Node_Id := Parent (N);
begin
Actuals := New_List (New_Copy_Tree (First_Actual));
if (Nkind (Parent_Node) = N_Function_Call
or else
Nkind (Parent_Node) = N_Procedure_Call_Statement)
-- Avoid recursive calls
and then N /= First (Parameter_Associations (Parent_Node))
then then
return True; Node_To_Replace := Parent_Node;
end if;
end if; Append_List_To (Actuals,
New_Copy_List (Parameter_Associations (Parent_Node)));
if Nkind (Parent_Node) = N_Procedure_Call_Statement then
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
else
pragma Assert (Nkind (Parent_Node) = N_Function_Call);
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
end if; end if;
Next_Elmt (Elmt); -- Parameterless call
end loop;
return False; else
end Try_Primitive_Operations; Node_To_Replace := N;
Call_Node :=
Make_Function_Call (Loc,
Name => New_Copy_Tree (Subprog),
Parameter_Associations => Actuals);
end if;
end Transform_Object_Operation;
------------------------------ ------------------------------
-- Try_Class_Wide_Operation -- -- Try_Class_Wide_Operation --
------------------------------ ------------------------------
function Try_Class_Wide_Operation function Try_Class_Wide_Operation
(New_Subprg : Node_Id; (Call_Node : Node_Id;
Obj : Node_Id; Node_To_Replace : Node_Id) return Boolean
Obj_Type : Entity_Id) return Boolean
is is
Deref : Node_Id; Anc_Type : Entity_Id;
Dummy : Node_Id;
Hom : Entity_Id; Hom : Entity_Id;
Typ : Entity_Id; Hom_Ref : Node_Id;
Success : Boolean;
begin begin
-- Loop through ancestor types -- Loop through ancestor types, traverse their homonym chains and
-- gather all interpretations of the subprogram.
Typ := Obj_Type; Anc_Type := Obj_Type;
loop loop
-- For each parent subtype we traverse all the homonym chain Hom := Current_Entity (Subprog);
-- looking for a candidate class-wide subprogram
Hom := Current_Entity (New_Subprg);
while Present (Hom) loop while Present (Hom) loop
if (Ekind (Hom) = E_Procedure if (Ekind (Hom) = E_Procedure
or else Ekind (Hom) = E_Function) or else
and then Present (First_Entity (Hom)) Ekind (Hom) = E_Function)
and then Etype (First_Entity (Hom)) = Class_Wide_Type (Typ) and then Present (First_Formal (Hom))
and then Etype (First_Formal (Hom)) =
Class_Wide_Type (Anc_Type)
then then
if Try_Replacement Hom_Ref := New_Reference_To (Hom, Loc);
(New_Prefix => Scope (Hom),
New_Subprg => Make_Identifier (Sloc (N), Chars (Hom)), -- When both the type of the object and the type of the
New_Formal => Obj, -- first formal of the primitive operation are tagged
Nam_Ent => Hom) -- access types, we use a node with the object as first
-- actual.
if Is_Access_Type (Etype (Obj))
and then Ekind (Etype (First_Formal (Hom))) =
E_Anonymous_Access_Type
then then
-- Allocate the node only once
if not Present (Call_Node_Case) then
Transform_Object_Operation (
Call_Node => Call_Node_Case,
First_Actual => Obj,
Node_To_Replace => Dummy,
Subprog => Subprog);
Set_Etype (Call_Node_Case, Any_Type);
Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
end if;
Set_Name (Call_Node_Case, Hom_Ref);
Analyze_One_Call (
N => Call_Node_Case,
Nam => Hom,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node_Case,
Node_To_Replace => Node_To_Replace,
Subprog => Hom_Ref);
return True; return True;
end if;
-- Try the implicit dereference in case of access type -- ??? comment required
elsif Is_Access_Type (Etype (Obj)) then else
Deref := Make_Explicit_Dereference (Sloc (Obj), Obj); Set_Name (Call_Node, Hom_Ref);
Set_Etype (Deref, Obj_Type);
Analyze_One_Call (
N => Call_Node,
Nam => Hom,
Report => False,
Success => Success);
if Success then
Complete_Object_Operation (
Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
Subprog => Hom_Ref);
if Try_Replacement
(New_Prefix => Scope (Hom),
New_Subprg => Make_Identifier (Sloc (N), Chars (Hom)),
New_Formal => Deref,
Nam_Ent => Hom)
then
return True; return True;
end if; end if;
end if; end if;
...@@ -4805,120 +4879,108 @@ package body Sem_Ch4 is ...@@ -4805,120 +4879,108 @@ package body Sem_Ch4 is
-- Climb to ancestor type if there is one -- Climb to ancestor type if there is one
exit when Etype (Typ) = Typ; exit when Etype (Anc_Type) = Anc_Type;
Typ := Etype (Typ); Anc_Type := Etype (Anc_Type);
end loop; end loop;
return False; return False;
end Try_Class_Wide_Operation; end Try_Class_Wide_Operation;
--------------------- -----------------------------
-- Try_Replacement -- -- Try_Primitive_Operation --
--------------------- -----------------------------
function Try_Replacement function Try_Primitive_Operation
(New_Prefix : Entity_Id; (Call_Node : Node_Id;
New_Subprg : Node_Id; Node_To_Replace : Node_Id) return Boolean
New_Formal : Node_Id;
Nam_Ent : Entity_Id) return Boolean
is is
Loc : constant Source_Ptr := Sloc (N); Dummy : Node_Id;
Call_Node : Node_Id; Elmt : Elmt_Id;
New_Name : Node_Id; Prim_Op : Entity_Id;
New_Actuals : List_Id; Prim_Op_Ref : Node_Id;
Node_To_Replace : Node_Id;
Success : Boolean; Success : Boolean;
begin begin
-- Step 1. Build the replacement node: a subprogram call node -- Look for the subprogram in the list of primitive operations.
-- with the object as its first actual parameter
New_Name := Make_Selected_Component (Loc,
Prefix => New_Reference_To (New_Prefix, Loc),
Selector_Name => New_Copy_Tree (New_Subprg));
New_Actuals := New_List (New_Copy_Tree (New_Formal)); Elmt := First_Elmt (Primitive_Operations (Obj_Type));
while Present (Elmt) loop
Prim_Op := Node (Elmt);
if (Nkind (Parent (N)) = N_Procedure_Call_Statement if Chars (Prim_Op) = Chars (Subprog)
or else Nkind (Parent (N)) = N_Function_Call) and then Present (First_Formal (Prim_Op))
then
Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
-- Protect against recursive call; It occurs in "..:= F (O.P)" -- When both the type of the object and the type of the first
-- formal of the primitive operation are tagged access types,
and then N /= First (Parameter_Associations (Parent (N))) -- we use a node with the object as first actual.
if Is_Access_Type (Etype (Obj))
and then Ekind (Etype (First_Formal (Prim_Op))) =
E_Anonymous_Access_Type
then then
Node_To_Replace := Parent (N); -- Allocate the node only once
Append_List_To
(New_Actuals,
New_Copy_List (Parameter_Associations (Node_To_Replace)));
if Nkind (Node_To_Replace) = N_Procedure_Call_Statement then if not Present (Call_Node_Case) then
Call_Node := Transform_Object_Operation (
Make_Procedure_Call_Statement (Loc, New_Name, New_Actuals); Call_Node => Call_Node_Case,
First_Actual => Obj,
Node_To_Replace => Dummy,
Subprog => Subprog);
else pragma Assert (Nkind (Node_To_Replace) = N_Function_Call); Set_Etype (Call_Node_Case, Any_Type);
Call_Node := Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
Make_Function_Call (Loc, New_Name, New_Actuals);
end if; end if;
-- Case of a function without parameters Set_Name (Call_Node_Case, Prim_Op_Ref);
else Analyze_One_Call (
Node_To_Replace := N; N => Call_Node_Case,
Nam => Prim_Op,
Report => False,
Success => Success);
Call_Node := if Success then
Make_Function_Call (Loc, New_Name, New_Actuals); Complete_Object_Operation (
end if; Call_Node => Call_Node_Case,
Node_To_Replace => Node_To_Replace,
Subprog => Prim_Op_Ref);
-- Step 2. Analyze the candidate replacement node. If it was return True;
-- successfully analyzed then replace the original node and end if;
-- carry out the full analysis to verify that there is no
-- conflict with overloaded subprograms.
-- To properly analyze the candidate we must initialize the type -- Comment required ???
-- of the result node of the call to the error type; it will be
-- reset if the type is successfully resolved.
Set_Etype (Call_Node, Any_Type); else
Set_Name (Call_Node, Prim_Op_Ref);
Analyze_One_Call Analyze_One_Call (
(N => Call_Node, N => Call_Node,
Nam => Nam_Ent, Nam => Prim_Op,
Report => False, -- do not post errors Report => False,
Success => Success); Success => Success);
if Success then if Success then
-- Previous analysis transformed the node with the name Complete_Object_Operation (
-- and we have to reset it to properly re-analyze it. Call_Node => Call_Node,
Node_To_Replace => Node_To_Replace,
New_Name := Subprog => Prim_Op_Ref);
Make_Selected_Component (Loc,
Prefix => New_Reference_To (New_Prefix, Loc),
Selector_Name => New_Copy_Tree (New_Subprg));
Set_Name (Call_Node, New_Name);
Set_Analyzed (Call_Node, False);
Set_Parent (Call_Node, Parent (Node_To_Replace));
Replace (Node_To_Replace, Call_Node);
Analyze (Node_To_Replace);
return True; return True;
end if;
end if;
end if;
-- Free all the nodes used for this test and return Next_Elmt (Elmt);
end loop;
else
Nodes.Set_Last (Last_Node);
return False; return False;
end if; end Try_Primitive_Operation;
end Try_Replacement;
-- Start of processing for Try_Object_Operation -- Start of processing for Try_Object_Operation
begin begin
-- Find the type of the object
Obj_Type := Etype (Obj);
if Is_Access_Type (Obj_Type) then if Is_Access_Type (Obj_Type) then
Obj_Type := Designated_Type (Obj_Type); Obj_Type := Designated_Type (Obj_Type);
end if; end if;
...@@ -4931,36 +4993,38 @@ package body Sem_Ch4 is ...@@ -4931,36 +4993,38 @@ package body Sem_Ch4 is
Obj_Type := Etype (Class_Wide_Type (Obj_Type)); Obj_Type := Etype (Class_Wide_Type (Obj_Type));
end if; end if;
-- Analyze the actuals Analyze_Actuals;
if (Nkind (Parent (N)) = N_Procedure_Call_Statement -- If the object is of an Access type, explicit dereference is
or else Nkind (Parent (N)) = N_Function_Call) -- required.
-- Protects against recursive call in case of "..:= F (O.Proc)" if Is_Access_Type (Etype (Obj)) then
First_Actual :=
Make_Explicit_Dereference (Sloc (Obj), Obj);
Set_Etype (First_Actual, Obj_Type);
else
First_Actual := Obj;
end if;
and then N /= First (Parameter_Associations (Parent (N))) -- Build a subprogram call node
then
Actual := First (Parameter_Associations (Parent (N)));
while Present (Actual) loop Transform_Object_Operation (
Analyze (Actual); Call_Node => Call_Node,
Check_Parameterless_Call (Actual); First_Actual => First_Actual,
Next_Actual (Actual); Node_To_Replace => Node_To_Replace,
end loop; Subprog => Subprog);
end if;
Last_Node := Last_Node_Id; Set_Etype (Call_Node, Any_Type);
Set_Parent (Call_Node, Parent (Node_To_Replace));
return Try_Primitive_Operations return
(New_Prefix => Scope (Obj_Type), Try_Primitive_Operation
New_Subprg => Selector_Name (N), (Call_Node => Call_Node,
Obj => Obj, Node_To_Replace => Node_To_Replace)
Obj_Type => Obj_Type)
or else or else
Try_Class_Wide_Operation Try_Class_Wide_Operation
(New_Subprg => Selector_Name (N), (Call_Node => Call_Node,
Obj => Obj, Node_To_Replace => Node_To_Replace);
Obj_Type => Obj_Type);
end Try_Object_Operation; end Try_Object_Operation;
end Sem_Ch4; end Sem_Ch4;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment