[Ada] Fix bug in generic+discriminants

[Arnaud Charlet]

Tested on i686-linux, committed on trunk.

In an instance, a generic actual type matches the corresponding actual,
of which it is a subtype, even though in some cases one may be a view
with unknown discriminants and not the other.
The following must compile quietly:
--
gcc -c -gnatc i.ads
--
package F is
   type A_Type (<>) is private;
private
   type A_Type is null record;
end;
generic
   type U_Type is tagged private;
package F.C is
   type V_Type is new U_Type with null record;
   procedure P (V : V_Type; A : A_Type);
end;
generic
   type B_Type (<>) is private;
package H is
   type T_Type is tagged null record;
   procedure P (T : T_Type; B : B_Type);
end;
with F.C, H;
package I is
   package J is new H (F.A_Type);
   package K is new F.C (J.T_Type);
end;

This patch also introduces a new compiler debug flag d.f which
suppresses folding of static expressions. This of course results
in seriously non-conforming behavior, but is useful sometimes
when tracking down handling of complex expressions.

A test program is

package K is
   X : Integer := 1 + 2;
end K;

Compiled with -gnatG -gnatd.f, this generates:

Source recreated from tree for K (spec)
---------------------------------------

k_E : boolean := false;

package k is
   k__x : integer := 1 + 2;
end k;

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,

-------------- next part --------------
Index: sem_eval.adb
===================================================================
--- sem_eval.adb	(revision 106884)
+++ sem_eval.adb	(working copy)
@@ -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 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 @@
          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 @@
    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 @@
 
       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 @@
         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 @@
 
    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 @@
 
          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 @@
 
          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 @@
         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