2010-10-05 Ed Schonberg <schonberg@adacore.com>

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

diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 3cb421b..d8b8ad0 100644 (file)
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -29,7 +29,6 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Errout;   use Errout;
 with Exp_Ch11; use Exp_Ch11;
-with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
 with Expander; use Expander;
 with Namet;    use Namet;
@@ -270,8 +269,8 @@ package body Exp_Prag is
    --------------------------
 
    procedure Expand_Pragma_Check (N : Node_Id) is
-      Loc  : constant Source_Ptr := Sloc (N);
       Cond : constant Node_Id    := Arg2 (N);
+      Loc  : constant Source_Ptr := Sloc (Cond);
       Nam  : constant Name_Id    := Chars (Arg1 (N));
       Msg  : Node_Id;
 
@@ -393,7 +392,7 @@ package body Exp_Prag is
          then
             return;
          elsif Nam = Name_Assertion then
-            Error_Msg_N ("?assertion will fail at run-time", N);
+            Error_Msg_N ("?assertion will fail at run time", N);
          else
             Error_Msg_N ("?check will fail at run time", N);
          end if;
@@ -485,29 +484,17 @@ package body Exp_Prag is
 
    procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
       Def_Id    : constant Entity_Id := Entity (Arg2 (N));
-      Typ       : Entity_Id;
       Init_Call : Node_Id;
 
    begin
       if Ekind (Def_Id) = E_Variable then
-         Typ  := Etype (Def_Id);
 
-         --  Iterate from declaration of object to import pragma, to find
-         --  generated initialization call for object, if any.
+         --  Find generated initialization call for object, if any
 
-         Init_Call := Next (Parent (Def_Id));
-         while Present (Init_Call) and then Init_Call /= N loop
-            if Has_Non_Null_Base_Init_Proc (Typ)
-              and then Nkind (Init_Call) = N_Procedure_Call_Statement
-              and then Is_Entity_Name (Name (Init_Call))
-              and then Entity (Name (Init_Call)) = Base_Init_Proc (Typ)
-            then
-               Remove (Init_Call);
-               exit;
-            else
-               Next (Init_Call);
-            end if;
-         end loop;
+         Init_Call := Find_Init_Call (Def_Id, Rep_Clause => N);
+         if Present (Init_Call) then
+            Remove (Init_Call);
+         end if;
 
          --  Any default initialization expression should be removed
          --  (e.g., null defaults for access objects, zero initialization
@@ -515,9 +502,7 @@ package body Exp_Prag is
          --  have explicit initialization, so the expression must have
          --  been generated by the compiler.
 
-         if Init_Call = N
-           and then Present (Expression (Parent (Def_Id)))
-         then
+         if No (Init_Call) and then Present (Expression (Parent (Def_Id))) then
             Set_Expression (Parent (Def_Id), Empty);
          end if;
       end if;
@@ -551,18 +536,14 @@ package body Exp_Prag is
       begin
          if Present (Call) then
             declare
-               Excep_Internal : constant Node_Id :=
-                                 Make_Defining_Identifier
-                                  (Loc, New_Internal_Name ('V'));
+               Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V');
                Export_Pragma  : Node_Id;
                Excep_Alias    : Node_Id;
                Excep_Object   : Node_Id;
-               Excep_Image : String_Id;
-               Exdata      : List_Id;
-               Lang1       : Node_Id;
-               Lang2       : Node_Id;
-               Lang3       : Node_Id;
-               Code        : Node_Id;
+               Excep_Image    : String_Id;
+               Exdata         : List_Id;
+               Lang_Char      : Node_Id;
+               Code           : Node_Id;
 
             begin
                if Present (Interface_Name (Id)) then
@@ -576,30 +557,16 @@ package body Exp_Prag is
                Exdata := Component_Associations (Expression (Parent (Id)));
 
                if Is_VMS_Exception (Id) then
-                  Lang1 := Next (First (Exdata));
-                  Lang2 := Next (Lang1);
-                  Lang3 := Next (Lang2);
+                  Lang_Char := Next (First (Exdata));
 
-                  Rewrite (Expression (Lang1),
+                  --  Change the one-character language designator to 'V'
+
+                  Rewrite (Expression (Lang_Char),
                     Make_Character_Literal (Loc,
                       Chars => Name_uV,
                       Char_Literal_Value =>
                         UI_From_Int (Character'Pos ('V'))));
-                  Analyze (Expression (Lang1));
-
-                  Rewrite (Expression (Lang2),
-                    Make_Character_Literal (Loc,
-                      Chars => Name_uM,
-                      Char_Literal_Value =>
-                        UI_From_Int (Character'Pos ('M'))));
-                  Analyze (Expression (Lang2));
-
-                  Rewrite (Expression (Lang3),
-                    Make_Character_Literal (Loc,
-                      Chars => Name_uS,
-                      Char_Literal_Value =>
-                        UI_From_Int (Character'Pos ('S'))));
-                  Analyze (Expression (Lang3));
+                  Analyze (Expression (Lang_Char));
 
                   if Exception_Code (Id) /= No_Uint then
                      Code :=