Commit 0356699b by Robert Dewar Committed by Arnaud Charlet

sem_eval.adb: Implement d.f flag

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb: Implement d.f flag
	(Subtype_Statically_Match): A generic actual type has unknown
	discriminants when the corresponding actual has a similar partial view.
	If the routine is called to validate the signature of an inherited
	operation in a child instance, the generic actual matches the full view,

From-SVN: r107004
parent d4810530
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,6 +32,7 @@ with Elists; use Elists; ...@@ -32,6 +32,7 @@ with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Eval_Fat; use Eval_Fat; with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Nmake; use Nmake; with Nmake; use Nmake;
with Nlists; use Nlists; with Nlists; use Nlists;
with Opt; use Opt; with Opt; use Opt;
...@@ -4004,11 +4005,21 @@ package body Sem_Eval is ...@@ -4004,11 +4005,21 @@ package body Sem_Eval is
return True; return True;
-- A definite type does not match an indefinite or classwide type -- A definite type does not match an indefinite or classwide type
-- However, a generic type with unknown discriminants may be
-- instantiated with a type with no discriminants, and conformance
-- checking on an inherited operation may compare the actual with
-- the subtype that renames it in the instance.
elsif elsif
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
then then
return False; if Is_Generic_Actual_Type (T1)
and then Etype (T1) = T2
then
return True;
else
return False;
end if;
-- Array type -- Array type
...@@ -4083,13 +4094,17 @@ package body Sem_Eval is ...@@ -4083,13 +4094,17 @@ package body Sem_Eval is
is is
begin begin
Stat := False; Stat := False;
Fold := False;
if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
return;
end if;
-- If operand is Any_Type, just propagate to result and do not -- If operand is Any_Type, just propagate to result and do not
-- try to fold, this prevents cascaded errors. -- try to fold, this prevents cascaded errors.
if Etype (Op1) = Any_Type then if Etype (Op1) = Any_Type then
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Fold := False;
return; return;
-- If operand raises constraint error, then replace node N with the -- If operand raises constraint error, then replace node N with the
...@@ -4099,7 +4114,6 @@ package body Sem_Eval is ...@@ -4099,7 +4114,6 @@ package body Sem_Eval is
elsif Raises_Constraint_Error (Op1) then elsif Raises_Constraint_Error (Op1) then
Rewrite_In_Raise_CE (N, Op1); Rewrite_In_Raise_CE (N, Op1);
Fold := False;
return; return;
-- If the operand is not static, then the result is not static, and -- If the operand is not static, then the result is not static, and
...@@ -4118,7 +4132,6 @@ package body Sem_Eval is ...@@ -4118,7 +4132,6 @@ package body Sem_Eval is
and then Is_Generic_Type (Etype (Op1)) and then Is_Generic_Type (Etype (Op1))
then then
Check_Non_Static_Context (Op1); Check_Non_Static_Context (Op1);
Fold := False;
return; return;
-- Here we have the case of an operand whose type is OK, which is -- Here we have the case of an operand whose type is OK, which is
...@@ -4145,13 +4158,17 @@ package body Sem_Eval is ...@@ -4145,13 +4158,17 @@ package body Sem_Eval is
begin begin
Stat := False; Stat := False;
Fold := False;
if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
return;
end if;
-- If either operand is Any_Type, just propagate to result and -- If either operand is Any_Type, just propagate to result and
-- do not try to fold, this prevents cascaded errors. -- do not try to fold, this prevents cascaded errors.
if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
Set_Etype (N, Any_Type); Set_Etype (N, Any_Type);
Fold := False;
return; return;
-- If left operand raises constraint error, then replace node N with -- If left operand raises constraint error, then replace node N with
...@@ -4166,7 +4183,6 @@ package body Sem_Eval is ...@@ -4166,7 +4183,6 @@ package body Sem_Eval is
Rewrite_In_Raise_CE (N, Op1); Rewrite_In_Raise_CE (N, Op1);
Set_Is_Static_Expression (N, Rstat); Set_Is_Static_Expression (N, Rstat);
Fold := False;
return; return;
-- Similar processing for the case of the right operand. Note that -- Similar processing for the case of the right operand. Note that
...@@ -4180,7 +4196,6 @@ package body Sem_Eval is ...@@ -4180,7 +4196,6 @@ package body Sem_Eval is
Rewrite_In_Raise_CE (N, Op2); Rewrite_In_Raise_CE (N, Op2);
Set_Is_Static_Expression (N, Rstat); Set_Is_Static_Expression (N, Rstat);
Fold := False;
return; return;
-- Exclude expressions of a generic modular type, as above -- Exclude expressions of a generic modular type, as above
...@@ -4189,7 +4204,6 @@ package body Sem_Eval is ...@@ -4189,7 +4204,6 @@ package body Sem_Eval is
and then Is_Generic_Type (Etype (Op1)) and then Is_Generic_Type (Etype (Op1))
then then
Check_Non_Static_Context (Op1); Check_Non_Static_Context (Op1);
Fold := False;
return; return;
-- If result is not static, then check non-static contexts on operands -- If result is not static, then check non-static contexts on operands
......
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