2012-05-15 Tristan Gingold <gingold@adacore.com>

	* a-exextr.adb: Add comment.

2012-05-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb: Minor reformatting (remove long dead code).

2012-05-15  Ed Schonberg  <schonberg@adacore.com>

	* aspects.adb, aspects.ads: Add aspects for Convention, Export,
	External_Name, Import, and Link_Name.
	* exp_prag.adb (Expand_Pragma_Import_Or_Interface): if the
	pragma comes from an aspect specification, the entity is the
	first argument.
	* sem_prag.adb (Analyze_Pragma, cases Pragma_Export and
	Pragma_Import): if the pragma comes from an aspect specification,
	the entity is the first argument, and the second has the value
	True by default.
	* sem_ch13.adb (Analyze_Aspect_Specifications): generate pragam
	for aspect Convention. Add placeholders for Link_Name and
	External_Name.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@187523 138bc75d-0d04-0410-961f-82ee72b054a4

8 files changed, 127 insertions, 84 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ec714b0cec5..7ad79d34c16 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2012-05-15  Tristan Gingold  <gingold@adacore.com>
+
+	* a-exextr.adb: Add comment.
+
+2012-05-15  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch3.adb: Minor reformatting (remove long dead code).
+
+2012-05-15  Ed Schonberg  <schonberg@adacore.com>
+
+	* aspects.adb, aspects.ads: Add aspects for Convention, Export,
+	External_Name, Import, and Link_Name.
+	* exp_prag.adb (Expand_Pragma_Import_Or_Interface): if the
+	pragma comes from an aspect specification, the entity is the
+	first argument.
+	* sem_prag.adb (Analyze_Pragma, cases Pragma_Export and
+	Pragma_Import): if the pragma comes from an aspect specification,
+	the entity is the first argument, and the second has the value
+	True by default.
+	* sem_ch13.adb (Analyze_Aspect_Specifications): generate pragam
+	for aspect Convention. Add placeholders for Link_Name and
+	External_Name.
+
 2012-05-15  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* exp_ch9.adb (Expand_N_Asynchronous_Select): Extract the statements
diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb
index b6ba237840f..d8f4072e402 100644
--- a/gcc/ada/a-exextr.adb
+++ b/gcc/ada/a-exextr.adb
@@ -162,14 +162,14 @@ package body Exception_Traces is
    -----------------------------------
 
    procedure Unhandled_Exception_Terminate is
-
-      --  Comments needed on why we do things this way ??? (see RH)
-
       Excep : Exception_Occurrence;
       --  This occurrence will be used to display a message after finalization.
       --  It is necessary to save a copy here, or else the designated value
       --  could be overwritten if an exception is raised during finalization
-      --  (even if that exception is caught).
+      --  (even if that exception is caught). The occurrence is saved on the
+      --  stack to avoid dynamic allocation (if this exception is due to lack
+      --  of space in the heap, we therefore avoid a second failure). We assume
+      --  that there is enough room on the stack however.
 
    begin
       Save_Occurrence (Excep, Get_Current_Excep.all.all);
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 86e70917d16..6605b7185ca 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -252,6 +252,7 @@ package body Aspects is
     Aspect_Component_Size               => Aspect_Component_Size,
     Aspect_Constant_Indexing            => Aspect_Constant_Indexing,
     Aspect_Contract_Case                => Aspect_Contract_Case,
+    Aspect_Convention                   => Aspect_Convention,
     Aspect_CPU                          => Aspect_CPU,
     Aspect_Default_Component_Value      => Aspect_Default_Component_Value,
     Aspect_Default_Iterator             => Aspect_Default_Iterator,
@@ -262,9 +263,12 @@ package body Aspects is
     Aspect_Dispatching_Domain           => Aspect_Dispatching_Domain,
     Aspect_Dynamic_Predicate            => Aspect_Predicate,
     Aspect_Elaborate_Body               => Aspect_Elaborate_Body,
+    Aspect_Export                       => Aspect_Export,
+    Aspect_External_Name                => Aspect_External_Name,
     Aspect_External_Tag                 => Aspect_External_Tag,
     Aspect_Favor_Top_Level              => Aspect_Favor_Top_Level,
     Aspect_Implicit_Dereference         => Aspect_Implicit_Dereference,
+    Aspect_Import                       => Aspect_Import,
     Aspect_Independent                  => Aspect_Independent,
     Aspect_Independent_Components       => Aspect_Independent_Components,
     Aspect_Inline                       => Aspect_Inline,
@@ -274,6 +278,7 @@ package body Aspects is
     Aspect_Interrupt_Priority           => Aspect_Interrupt_Priority,
     Aspect_Invariant                    => Aspect_Invariant,
     Aspect_Iterator_Element             => Aspect_Iterator_Element,
+    Aspect_Link_Name                    => Aspect_Link_Name,
     Aspect_Lock_Free                    => Aspect_Lock_Free,
     Aspect_Machine_Radix                => Aspect_Machine_Radix,
     Aspect_No_Return                    => Aspect_No_Return,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 523412bd0e8..330f72a7ef6 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -51,6 +51,7 @@ package Aspects is
       Aspect_Component_Size,
       Aspect_Constant_Indexing,
       Aspect_Contract_Case,                 -- GNAT
+      Aspect_Convention,
       Aspect_CPU,
       Aspect_Default_Component_Value,
       Aspect_Default_Iterator,
@@ -59,12 +60,14 @@ package Aspects is
       Aspect_Dimension_System,              -- GNAT
       Aspect_Dispatching_Domain,
       Aspect_Dynamic_Predicate,
+      Aspect_External_Name,
       Aspect_External_Tag,
       Aspect_Implicit_Dereference,
       Aspect_Input,
       Aspect_Interrupt_Priority,
       Aspect_Invariant,
       Aspect_Iterator_Element,
+      Aspect_Link_Name,
       Aspect_Machine_Radix,
       Aspect_Object_Size,                   -- GNAT
       Aspect_Output,
@@ -121,9 +124,11 @@ package Aspects is
       Aspect_Atomic,
       Aspect_Atomic_Components,
       Aspect_Discard_Names,
+      Aspect_Export,
       Aspect_Favor_Top_Level,               -- GNAT
       Aspect_Independent,
       Aspect_Independent_Components,
+      Aspect_Import,
       Aspect_Inline,
       Aspect_Inline_Always,                 -- GNAT
       Aspect_Interrupt_Handler,
@@ -269,6 +274,7 @@ package Aspects is
                         Aspect_Component_Size          => Expression,
                         Aspect_Constant_Indexing       => Name,
                         Aspect_Contract_Case           => Expression,
+                        Aspect_Convention              => Name,
                         Aspect_CPU                     => Expression,
                         Aspect_Default_Component_Value => Expression,
                         Aspect_Default_Iterator        => Name,
@@ -277,12 +283,14 @@ package Aspects is
                         Aspect_Dimension_System        => Expression,
                         Aspect_Dispatching_Domain      => Expression,
                         Aspect_Dynamic_Predicate       => Expression,
+                        Aspect_External_Name           => Expression,
                         Aspect_External_Tag            => Expression,
                         Aspect_Implicit_Dereference    => Name,
                         Aspect_Input                   => Name,
                         Aspect_Interrupt_Priority      => Expression,
                         Aspect_Invariant               => Expression,
                         Aspect_Iterator_Element        => Name,
+                        Aspect_Link_Name               => Expression,
                         Aspect_Machine_Radix           => Expression,
                         Aspect_Object_Size             => Expression,
                         Aspect_Output                  => Name,
@@ -336,6 +344,7 @@ package Aspects is
      Aspect_Component_Size               => Name_Component_Size,
      Aspect_Constant_Indexing            => Name_Constant_Indexing,
      Aspect_Contract_Case                => Name_Contract_Case,
+     Aspect_Convention                   => Name_Convention,
      Aspect_CPU                          => Name_CPU,
      Aspect_Default_Iterator             => Name_Default_Iterator,
      Aspect_Default_Value                => Name_Default_Value,
@@ -346,9 +355,12 @@ package Aspects is
      Aspect_Dispatching_Domain           => Name_Dispatching_Domain,
      Aspect_Dynamic_Predicate            => Name_Dynamic_Predicate,
      Aspect_Elaborate_Body               => Name_Elaborate_Body,
+     Aspect_External_Name                => Name_External_Name,
      Aspect_External_Tag                 => Name_External_Tag,
+     Aspect_Export                       => Name_Export,
      Aspect_Favor_Top_Level              => Name_Favor_Top_Level,
      Aspect_Implicit_Dereference         => Name_Implicit_Dereference,
+     Aspect_Import                       => Name_Import,
      Aspect_Independent                  => Name_Independent,
      Aspect_Independent_Components       => Name_Independent_Components,
      Aspect_Inline                       => Name_Inline,
@@ -358,6 +370,7 @@ package Aspects is
      Aspect_Interrupt_Priority           => Name_Interrupt_Priority,
      Aspect_Invariant                    => Name_Invariant,
      Aspect_Iterator_Element             => Name_Iterator_Element,
+     Aspect_Link_Name                    => Name_Link_Name,
      Aspect_Lock_Free                    => Name_Lock_Free,
      Aspect_Machine_Radix                => Name_Machine_Radix,
      Aspect_No_Return                    => Name_No_Return,
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 8cb084d6ba2..d283a6e397e 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2012, 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- --
@@ -527,10 +527,18 @@ package body Exp_Prag is
    --  seen (i.e. this elaboration cannot be deferred to the freeze point).
 
    procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
-      Def_Id    : constant Entity_Id := Entity (Arg2 (N));
+      Def_Id    : Entity_Id;
       Init_Call : Node_Id;
 
    begin
+      --  If the pragma comes from an aspect, the entity is its first argument.
+
+      if Present (Corresponding_Aspect (N)) then
+         Def_Id := Entity (Arg1 (N));
+      else
+         Def_Id := Entity (Arg2 (N));
+      end if;
+
       if Ekind (Def_Id) = E_Variable then
 
          --  Find generated initialization call for object, if any
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 6b46b2d2688..fbbde853492 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1168,6 +1168,14 @@ package body Sem_Ch13 is
                --  the second argument is a local name referring to the entity,
                --  and the first argument is the aspect definition expression.
 
+               when Aspect_Convention =>
+                  Aitem :=
+                    Make_Pragma (Loc,
+                      Pragma_Argument_Associations =>
+                        New_List (Relocate_Node (Expr), Ent),
+                      Pragma_Identifier            =>
+                        Make_Identifier (Sloc (Id), Chars (Id)));
+
                when Aspect_Warnings =>
 
                   --  Construct the pragma
@@ -1562,6 +1570,13 @@ package body Sem_Ch13 is
                   Analyze_Aspect_Dimension_System (N, Id, Expr);
                   goto Continue;
 
+               --  Placeholders for new aspects without corresponding pragmas
+
+               when Aspect_External_Name =>
+                  null;
+
+               when Aspect_Link_Name =>
+                  null;
             end case;
 
             --  If a delay is required, we delay the freeze (not much point in
@@ -6199,6 +6214,9 @@ package body Sem_Ch13 is
          when Aspect_Attach_Handler =>
             T := RTE (RE_Interrupt_ID);
 
+         when Aspect_Convention =>
+            null;
+
          --  Default_Value is resolved with the type entity in question
 
          when Aspect_Default_Value =>
@@ -6226,6 +6244,12 @@ package body Sem_Ch13 is
          when Aspect_External_Tag =>
             T := Standard_String;
 
+         when Aspect_External_Name =>
+            T := Standard_String;
+
+         when Aspect_Link_Name =>
+            T := Standard_String;
+
          when Aspect_Priority | Aspect_Interrupt_Priority =>
             T := Standard_Integer;
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 233d5ffba7f..e6f3c4c7c9b 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3592,80 +3592,6 @@ package body Sem_Ch3 is
          else
             Validate_Controlled_Object (Id);
          end if;
-
-         --  Generate a warning when an initialization causes an obvious ABE
-         --  violation. If the init expression is a simple aggregate there
-         --  shouldn't be any initialize/adjust call generated. This will be
-         --  true as soon as aggregates are built in place when possible.
-
-         --  ??? at the moment we do not generate warnings for temporaries
-         --  created for those aggregates although Program_Error might be
-         --  generated if compiled with -gnato.
-
-         if Is_Controlled (Etype (Id))
-            and then Comes_From_Source (Id)
-         then
-            declare
-               BT : constant Entity_Id := Base_Type (Etype (Id));
-
-               Implicit_Call : Entity_Id;
-               pragma Warnings (Off, Implicit_Call);
-               --  ??? what is this for (never referenced!)
-
-               function Is_Aggr (N : Node_Id) return Boolean;
-               --  Check that N is an aggregate
-
-               -------------
-               -- Is_Aggr --
-               -------------
-
-               function Is_Aggr (N : Node_Id) return Boolean is
-               begin
-                  case Nkind (Original_Node (N)) is
-                     when N_Aggregate | N_Extension_Aggregate =>
-                        return True;
-
-                     when N_Qualified_Expression |
-                          N_Type_Conversion      |
-                          N_Unchecked_Type_Conversion =>
-                        return Is_Aggr (Expression (Original_Node (N)));
-
-                     when others =>
-                        return False;
-                  end case;
-               end Is_Aggr;
-
-            begin
-               --  If no underlying type, we already are in an error situation.
-               --  Do not try to add a warning since we do not have access to
-               --  prim-op list.
-
-               if No (Underlying_Type (BT)) then
-                  Implicit_Call := Empty;
-
-               --  A generic type does not have usable primitive operators.
-               --  Initialization calls are built for instances.
-
-               elsif Is_Generic_Type (BT) then
-                  Implicit_Call := Empty;
-
-               --  If the init expression is not an aggregate, an adjust call
-               --  will be generated
-
-               elsif Present (E) and then not Is_Aggr (E) then
-                  Implicit_Call := Find_Prim_Op (BT, Name_Adjust);
-
-               --  If no init expression and we are not in the deferred
-               --  constant case, an Initialize call will be generated
-
-               elsif No (E) and then not Constant_Present (N) then
-                  Implicit_Call := Find_Prim_Op (BT, Name_Initialize);
-
-               else
-                  Implicit_Call := Empty;
-               end if;
-            end;
-         end if;
       end if;
 
       if Has_Task (Etype (Id)) then
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1cd35904a20..28bb57456eb 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -8633,7 +8633,30 @@ package body Sem_Prag is
                 Name_Entity,
                 Name_External_Name,
                 Name_Link_Name));
-            Check_At_Least_N_Arguments (2);
+
+            if Present (Corresponding_Aspect (N)) then
+
+               --  If the pragma comes from an Aspect, there is a single entity
+               --  parameter and an optional booean value with default true.
+               --  The convention must be provided by a separate aspect.
+
+               Check_At_Least_N_Arguments (1);
+               Check_At_Most_N_Arguments  (2);
+               Def_Id := Entity (Arg1);
+
+               if No (Arg2) then
+
+                  --  If the aspect has a default True value, set corresponding
+                  --  flag on the entity.
+
+                  Set_Is_Exported (Def_Id);
+               end if;
+               return;
+
+            else
+               Check_At_Least_N_Arguments (2);
+            end if;
+
             Check_At_Most_N_Arguments  (4);
             Process_Convention (C, Def_Id);
 
@@ -9566,9 +9589,30 @@ package body Sem_Prag is
                 Name_Entity,
                 Name_External_Name,
                 Name_Link_Name));
-            Check_At_Least_N_Arguments (2);
-            Check_At_Most_N_Arguments  (4);
-            Process_Import_Or_Interface;
+
+            if Present (Corresponding_Aspect (N)) then
+
+               --  If the pragma comes from an Aspect, there is a single entity
+               --  parameter and an optional booean value with default true.
+               --  The convention must be provided by a separate aspect.
+
+               Check_At_Least_N_Arguments (1);
+               Check_At_Most_N_Arguments  (2);
+
+               if No (Arg2) then
+
+                  --  If the aspect has a default True value, set corresponding
+                  --  flag on the entity.
+
+                  Set_Is_Imported (Entity (Arg1));
+               end if;
+               return;
+
+            else
+               Check_At_Least_N_Arguments (2);
+               Check_At_Most_N_Arguments  (4);
+               Process_Import_Or_Interface;
+            end if;
 
          ----------------------
          -- Import_Exception --