FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sem_eval.adb: Implement d.f flag

Browse source 
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
This commit is contained in:
Robert Dewar 2005-11-15 15:03:33 +01:00 • committed by Arnaud Charlet
parent d4810530b8
commit 0356699b56
1 changed files with 23 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

32
gcc/ada/sem_eval.adb
View file

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -32,6 +32,7 @@ with Elists; use Elists;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
@ -4004,11 +4005,21 @@ package body Sem_Eval is
return True;
-- 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
Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
then
return False;
if Is_Generic_Actual_Type (T1)
and then Etype (T1) = T2
then
return True;
else
return False;
end if;
-- Array type
@ -4083,13 +4094,17 @@ package body Sem_Eval is
is
begin
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
-- try to fold, this prevents cascaded errors.
if Etype (Op1) = Any_Type then
Set_Etype (N, Any_Type);
Fold := False;
return;
-- If operand raises constraint error, then replace node N with the
@ -4099,7 +4114,6 @@ package body Sem_Eval is
elsif Raises_Constraint_Error (Op1) then
Rewrite_In_Raise_CE (N, Op1);
Fold := False;
return;
-- If the operand is not static, then the result is not static, and
@ -4118,7 +4132,6 @@ package body Sem_Eval is
and then Is_Generic_Type (Etype (Op1))
then
Check_Non_Static_Context (Op1);
Fold := False;
return;
-- Here we have the case of an operand whose type is OK, which is
@ -4145,13 +4158,17 @@ package body Sem_Eval is
begin
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
-- do not try to fold, this prevents cascaded errors.
if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
Set_Etype (N, Any_Type);
Fold := False;
return;
-- If left operand raises constraint error, then replace node N with
@ -4166,7 +4183,6 @@ package body Sem_Eval is
Rewrite_In_Raise_CE (N, Op1);
Set_Is_Static_Expression (N, Rstat);
Fold := False;
return;
-- Similar processing for the case of the right operand. Note that
@ -4180,7 +4196,6 @@ package body Sem_Eval is
Rewrite_In_Raise_CE (N, Op2);
Set_Is_Static_Expression (N, Rstat);
Fold := False;
return;
-- Exclude expressions of a generic modular type, as above
@ -4189,7 +4204,6 @@ package body Sem_Eval is
and then Is_Generic_Type (Etype (Op1))
then
Check_Non_Static_Context (Op1);
Fold := False;
return;
-- If result is not static, then check non-static contexts on operands