* targhooks.c (default_stack_protect_guard): Avoid sharing RTL

[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_intr.adb

diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 6f29b37..da6cf5a 100644 (file)
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, 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- --
@@ -39,19 +39,20 @@ with Freeze;   use Freeze;
 with Namet;    use Namet;
 with Nmake;    use Nmake;
 with Nlists;   use Nlists;
+with Opt;      use Opt;
 with Restrict; use Restrict;
 with Rident;   use Rident;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
+with Sem_Type; use Sem_Type;
 with Sem_Util; use Sem_Util;
 with Sinfo;    use Sinfo;
 with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
-with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 with Urealp;   use Urealp;
@@ -165,7 +166,7 @@ package body Exp_Intr is
          --  If the result type is not parent of Tag_Arg then we need to
          --  locate the tag of the secondary dispatch table.
 
-         if not Is_Parent (Etype (Result_Typ), Etype (Tag_Arg)) then
+         if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
             pragma Assert (not Is_Interface (Etype (Tag_Arg)));
 
             Iface_Tag :=
@@ -218,7 +219,7 @@ package body Exp_Intr is
       --  checks are suppressed for the result type or VM_Target /= No_VM
 
       if Tag_Checks_Suppressed (Etype (Result_Typ))
-        or else VM_Target /= No_VM
+        or else not Tagged_Type_Expansion
       then
          null;
 
@@ -233,19 +234,28 @@ package body Exp_Intr is
       --  the tag in the table of ancestor tags.
 
       elsif not Is_Interface (Result_Typ) then
-         Insert_Action (N,
-           Make_Implicit_If_Statement (N,
-             Condition =>
-               Make_Op_Not (Loc,
-                 Build_CW_Membership (Loc,
-                   Obj_Tag_Node => Duplicate_Subexpr (Tag_Arg),
-                   Typ_Tag_Node =>
-                     New_Reference_To (
-                        Node (First_Elmt (Access_Disp_Table (
-                                            Root_Type (Result_Typ)))), Loc))),
-             Then_Statements =>
-               New_List (Make_Raise_Statement (Loc,
-                           New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+         declare
+            Obj_Tag_Node : Node_Id := Duplicate_Subexpr (Tag_Arg);
+            CW_Test_Node : Node_Id;
+
+         begin
+            Build_CW_Membership (Loc,
+              Obj_Tag_Node => Obj_Tag_Node,
+              Typ_Tag_Node =>
+                New_Reference_To (
+                   Node (First_Elmt (Access_Disp_Table (
+                                       Root_Type (Result_Typ)))), Loc),
+              Related_Nod => N,
+              New_Node    => CW_Test_Node);
+
+            Insert_Action (N,
+              Make_Implicit_If_Statement (N,
+                Condition =>
+                  Make_Op_Not (Loc, CW_Test_Node),
+                Then_Statements =>
+                  New_List (Make_Raise_Statement (Loc,
+                              New_Occurrence_Of (RTE (RE_Tag_Error), Loc)))));
+         end;
 
       --  Call IW_Membership test if the Result_Type is an abstract interface
       --  to look for the tag in the table of interface tags.
@@ -393,6 +403,13 @@ package body Exp_Intr is
       Nam : Name_Id;
 
    begin
+      --  If an external name is specified for the intrinsic, it is handled
+      --  by the back-end: leave the call node unchanged for now.
+
+      if Present (Interface_Name (E)) then
+         return;
+      end if;
+
       --  If the intrinsic subprogram is generic, gets its original name
 
       if Present (Parent (E))
@@ -814,7 +831,7 @@ package body Exp_Intr is
 
       --  Processing for pointer to controlled type
 
-      if Controlled_Type (Desig_T) then
+      if Needs_Finalization (Desig_T) then
          Deref :=
            Make_Explicit_Dereference (Loc,
              Prefix => Duplicate_Subexpr_No_Checks (Arg));
@@ -1010,14 +1027,19 @@ package body Exp_Intr is
                else
                   D_Type := Make_Defining_Identifier (Loc,
                               New_Internal_Name ('A'));
-                  Insert_Action (N,
+                  Insert_Action (Deref,
                     Make_Subtype_Declaration (Loc,
                       Defining_Identifier => D_Type,
                       Subtype_Indication  => D_Subtyp));
-                  Freeze_Itype (D_Type, N);
 
                end if;
 
+               --  Force freezing at the point of the dereference. For the
+               --  class wide case, this avoids having the subtype frozen
+               --  before the equivalent type.
+
+               Freeze_Itype (D_Type, Deref);
+
                Set_Actual_Designated_Subtype (Free_Node, D_Type);
             end;
 
@@ -1033,7 +1055,7 @@ package body Exp_Intr is
       --    free (Base_Address (Obj_Ptr))
 
       if Is_Interface (Directly_Designated_Type (Typ))
-        and then VM_Target = No_VM
+        and then Tagged_Type_Expansion
       then
          Set_Expression (Free_Node,
            Unchecked_Convert_To (Typ,