checks.adb (Insert_Valid_Check): Apply validity check to expression of conversion...

	* checks.adb (Insert_Valid_Check): Apply validity check to expression
	of conversion, not to result of conversion.

	* sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag
	before freezing parent. If the declarations are mutually recursive,
	an access to the current record type may be frozen before the
	derivation is complete.

From-SVN: r47894

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c32f52c38dbd3077ff20631b60c3ebfee6e17a02..9a1631ba9adadc596e09822b0051602ca05f0388 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,15 @@
+2001-12-11  Robert Dewar <dewar@gnat.com>
+
+       * checks.adb (Insert_Valid_Check): Apply validity check to expression 
+       of conversion, not to result of conversion.
+
+2001-12-11  Ed Schonberg <schonber@gnat.com>
+       
+       * sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag 
+       before freezing parent. If the declarations are mutually recursive, 
+       an access to the current record type may be frozen before the 
+       derivation is complete.
+
 2001-12-05  Vincent Celier <celier@gnat.com>
 
        * gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY, 

diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 67723b5b98654cd13e992c868c322715655b0444..bf8064175586157f7e5c1fbd60a8cf23b4f6bd7d 100644 (file)
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -2691,6 +2691,7 @@ package body Checks is
 
    procedure Insert_Valid_Check (Expr : Node_Id) is
       Loc : constant Source_Ptr := Sloc (Expr);
+      Exp : Node_Id;
 
    begin
       --  Do not insert if checks off, or if not checking validity
@@ -2698,27 +2699,35 @@ package body Checks is
       if Range_Checks_Suppressed (Etype (Expr))
         or else (not Validity_Checks_On)
       then
-         null;
+         return;
+      end if;
 
-      --  Otherwise insert the validity check. Note that we do this with
-      --  validity checks turned off, to avoid recursion, we do not want
-      --  validity checks on the validity checking code itself!
+      --  If we have a checked conversion, then validity check applies to
+      --  the expression inside the conversion, not the result, since if
+      --  the expression inside is valid, then so is the conversion result.
 
-      else
-         Validity_Checks_On := False;
-         Insert_Action
-           (Expr,
-            Make_Raise_Constraint_Error (Loc,
-              Condition =>
-                Make_Op_Not (Loc,
-                  Right_Opnd =>
-                    Make_Attribute_Reference (Loc,
-                      Prefix =>
-                        Duplicate_Subexpr (Expr, Name_Req => True),
-                      Attribute_Name => Name_Valid))),
-            Suppress => All_Checks);
-         Validity_Checks_On := True;
-      end if;
+      Exp := Expr;
+      while Nkind (Exp) = N_Type_Conversion loop
+         Exp := Expression (Exp);
+      end loop;
+
+      --  insert the validity check. Note that we do this with validity
+      --  checks turned off, to avoid recursion, we do not want validity
+      --  checks on the validity checking code itself!
+
+      Validity_Checks_On := False;
+      Insert_Action
+        (Expr,
+         Make_Raise_Constraint_Error (Loc,
+           Condition =>
+             Make_Op_Not (Loc,
+               Right_Opnd =>
+                 Make_Attribute_Reference (Loc,
+                   Prefix =>
+                     Duplicate_Subexpr (Exp, Name_Req => True),
+                   Attribute_Name => Name_Valid))),
+         Suppress => All_Checks);
+      Validity_Checks_On := True;
    end Insert_Valid_Check;
 
    --------------------------

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 154c2347c6dfe42c6414d3fe57ee1131a66e4e81..dff460cfca244aed4af57b51a0e2702db8c6c4bb 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5032,6 +5032,7 @@ package body Sem_Ch3 is
       Set_Size_Info      (Derived_Type,                 Parent_Type);
       Set_RM_Size        (Derived_Type, RM_Size        (Parent_Type));
       Set_Convention     (Derived_Type, Convention     (Parent_Type));
+      Set_Is_Controlled  (Derived_Type, Is_Controlled  (Parent_Type));
       Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
 
       case Ekind (Parent_Type) is