[multiple changes]

2011-09-02  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Declare "gcc"
	as the compiler driver so Is_Compilable returns True for sources.
	* prj-nmsc.adb (Override_Kind): When Kind is Sep, set the source
	for the body.

2011-09-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Analyze_PPC_In_Decl_Part): for a class-wide
	condition, a reference to a controlling formal must be interpreted
	as having the class-wide type (or an access to such) so that the
	inherited condition can be properly applied to any overriding
	operation (see ARM12 6.6.1 (7)).

2011-09-02  Tristan Gingold  <gingold@adacore.com>

	* init.c (__gnat_is_vms_v7): Fix case and add prototype
	for LIB$GETSYI.

2011-09-02  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the
	initializing expression of a class-wide interface object declaration
	if its type is limited.

2011-09-02  Johannes Kanig  <kanig@adacore.com>

	* sem_util.adb (Unique_Name): To obtain a unique name for enumeration
	literals, take into account the type name; the type is *not*
	the scope for an enumeration literal.

2011-09-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Check_Overriding_Indicator): add special check
	to reject an overriding indicator on a user-defined Adjust
	subprogram for a limited controlled type.

2011-09-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Actuals): add missing call to Resolve
	for an actual that is a function call returning an unconstrained
	limited controlled type.

2011-09-02  Tristan Gingold  <gingold@adacore.com>

	* g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7

2011-09-02  Johannes Kanig  <kanig@adacore.com>

	* alfa.ads (Name_Of_Heap_Variable): Change value of the HEAP variable
	from "HEAP" to __HEAP Change comment that refers to that variable
	* put_alfa.adb: Change comment that refers to that variable

From-SVN: r178458

12 files changed, 257 insertions, 30 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1f8cebf..0c81255 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,57 @@
+2011-09-02  Vincent Celier  <celier@adacore.com>
+
+	* prj-conf.adb (Add_Default_GNAT_Naming_Scheme): Declare "gcc"
+	as the compiler driver so Is_Compilable returns True for sources.
+	* prj-nmsc.adb (Override_Kind): When Kind is Sep, set the source
+	for the body.
+
+2011-09-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_prag.adb (Analyze_PPC_In_Decl_Part): for a class-wide
+	condition, a reference to a controlling formal must be interpreted
+	as having the class-wide type (or an access to such) so that the
+	inherited condition can be properly applied to any overriding
+	operation (see ARM12 6.6.1 (7)).
+
+2011-09-02  Tristan Gingold  <gingold@adacore.com>
+
+	* init.c (__gnat_is_vms_v7): Fix case and add prototype
+	for LIB$GETSYI.
+
+2011-09-02  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch3.adb (Expand_N_Object_Declaration): Do not copy the
+	initializing expression of a class-wide interface object declaration
+	if its type is limited.
+
+2011-09-02  Johannes Kanig  <kanig@adacore.com>
+
+	* sem_util.adb (Unique_Name): To obtain a unique name for enumeration
+	literals, take into account the type name; the type is *not*
+	the scope for an enumeration literal.
+
+2011-09-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch6.adb (Check_Overriding_Indicator): add special check
+	to reject an overriding indicator on a user-defined Adjust
+	subprogram for a limited controlled type.
+
+2011-09-02  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_res.adb (Resolve_Actuals): add missing call to Resolve
+	for an actual that is a function call returning an unconstrained
+	limited controlled type.
+
+2011-09-02  Tristan Gingold  <gingold@adacore.com>
+
+	* g-socthi-vms.adb (c_sendmsg, c_recvmsg): Use unpacked msg if on vms 7
+
+2011-09-02  Johannes Kanig  <kanig@adacore.com>
+
+	* alfa.ads (Name_Of_Heap_Variable): Change value of the HEAP variable
+	from "HEAP" to __HEAP Change comment that refers to that variable
+	* put_alfa.adb: Change comment that refers to that variable
+
 2011-09-02  Robert Dewar  <dewar@adacore.com>
 
 	* exp_ch4.adb, exp_ch6.adb, prj-nmsc.adb: Minor reformatting.
diff --git a/gcc/ada/alfa.ads b/gcc/ada/alfa.ads
index 95c4be3..7531f9e 100644
--- a/gcc/ada/alfa.ads
+++ b/gcc/ada/alfa.ads
@@ -91,8 +91,7 @@ package Alfa is
 
    --    FS . scope line type col entity (-> spec-file . spec-scope)?
 
-   --      What is the ? marke here, is it part of the actual syntax, or is
-   --      it a query about a problem, in which case it should be ???
+   --      (The ? mark stands for an optional entry in the syntax)
 
    --      scope is the ones-origin scope number for the current file (e.g. 2 =
    --      reference to the second FS line in this FD block).
@@ -176,9 +175,9 @@ package Alfa is
    --        s = subprogram reference in a static call
 
    --  Special entries for reads and writes to memory reference a special
-   --  variable called "HEAP". These special entries are present in every scope
-   --  where reads and writes to memory are present. Line and column for this
-   --  special variable are always 0.
+   --  variable called "__HEAP". These special entries are present in every
+   --  scope where reads and writes to memory are present. Line and column for
+   --  this special variable are always 0.
 
    --    Examples: ??? add examples here
 
@@ -336,7 +335,7 @@ package Alfa is
    -- Constants --
    ---------------
 
-   Name_Of_Heap_Variable : constant String := "HEAP";
+   Name_Of_Heap_Variable : constant String := "__HEAP";
    --  Name of special variable used in effects to denote reads and writes
    --  through explicit dereference.
 
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 56d0fa2..a8cde1e 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -4841,11 +4841,11 @@ package body Exp_Ch3 is
             return;
 
          --  Ada 2005 (AI-251): Rewrite the expression that initializes a
-         --  class-wide object to ensure that we copy the full object,
-         --  unless we are targetting a VM where interfaces are handled by
-         --  VM itself. Note that if the root type of Typ is an ancestor
-         --  of Expr's type, both types share the same dispatch table and
-         --  there is no need to displace the pointer.
+         --  class-wide interface object to ensure that we copy the full
+         --  object, unless we are targetting a VM where interfaces are handled
+         --  by VM itself. Note that if the root type of Typ is an ancestor of
+         --  Expr's type, both types share the same dispatch table and there is
+         --  no need to displace the pointer.
 
          elsif Comes_From_Source (N)
            and then Is_Interface (Typ)
@@ -4978,13 +4978,31 @@ package body Exp_Ch3 is
 
                      --  Copy the object
 
-                     Insert_Action (N,
-                       Make_Object_Declaration (Loc,
-                         Defining_Identifier => Obj_Id,
-                         Object_Definition =>
-                           New_Occurrence_Of
-                             (Etype (Object_Definition (N)), Loc),
-                         Expression => New_Expr));
+                     if not Is_Limited_Record (Expr_Typ) then
+                        Insert_Action (N,
+                          Make_Object_Declaration (Loc,
+                            Defining_Identifier => Obj_Id,
+                            Object_Definition =>
+                              New_Occurrence_Of
+                                (Etype (Object_Definition (N)), Loc),
+                            Expression => New_Expr));
+
+                     --  Rename limited type object since they cannot be copied
+                     --  This case occurs when the initialization expression
+                     --  has been previously expanded into a temporary object.
+
+                     else pragma Assert (not Comes_From_Source (Expr_Q));
+
+                        Insert_Action (N,
+                          Make_Object_Renaming_Declaration (Loc,
+                            Defining_Identifier => Obj_Id,
+                            Subtype_Mark =>
+                              New_Occurrence_Of
+                                (Etype (Object_Definition (N)), Loc),
+                            Name =>
+                              Unchecked_Convert_To
+                                (Etype (Object_Definition (N)), New_Expr)));
+                     end if;
 
                      --  Dynamically reference the tag associated with the
                      --  interface.
diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb
index c075ae5..51c28fb 100644
--- a/gcc/ada/g-socthi-vms.adb
+++ b/gcc/ada/g-socthi-vms.adb
@@ -42,7 +42,15 @@ package body GNAT.Sockets.Thin is
    pragma Pack (VMS_Msghdr);
    --  On VMS 8.x (unlike other platforms), struct msghdr is packed, so a
    --  specific derived type is required. This structure was not packed on
-   --  VMS 7.3, so sendmsg and recvmsg fail on earlier VMS versions.
+   --  VMS 7.3.
+
+   function Is_VMS_V7 return Integer;
+   pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7");
+   --  Helper (defined in init.c) that returns a non-zero value if the VMS
+   --  version is 7.x.
+
+   VMS_V7 : constant Boolean := Is_VMS_V7 /= 0;
+   --  True if VMS version is 7.x.
 
    Non_Blocking_Sockets : aliased Fd_Set;
    --  When this package is initialized with Process_Blocking_IO set to True,
@@ -295,15 +303,24 @@ package body GNAT.Sockets.Thin is
    is
       Res : C.int;
 
+      Msg_Addr : System.Address;
+
       GNAT_Msg : Msghdr;
       for GNAT_Msg'Address use Msg;
       pragma Import (Ada, GNAT_Msg);
 
-      VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
+      VMS_Msg : aliased VMS_Msghdr;
 
    begin
+      if VMS_V7 then
+         Msg_Addr := Msg;
+      else
+         VMS_Msg := VMS_Msghdr (GNAT_Msg);
+         Msg_Addr := VMS_Msg'Address;
+      end if;
+
       loop
-         Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags);
+         Res := Syscall_Recvmsg (S, Msg_Addr, Flags);
          exit when SOSC.Thread_Blocking_IO
            or else Res /= Failure
            or else Non_Blocking_Socket (S)
@@ -311,7 +328,9 @@ package body GNAT.Sockets.Thin is
          delay Quantum;
       end loop;
 
-      GNAT_Msg := Msghdr (VMS_Msg);
+      if not VMS_V7 then
+         GNAT_Msg := Msghdr (VMS_Msg);
+      end if;
 
       return System.CRTL.ssize_t (Res);
    end C_Recvmsg;
@@ -327,15 +346,24 @@ package body GNAT.Sockets.Thin is
    is
       Res : C.int;
 
+      Msg_Addr : System.Address;
+
       GNAT_Msg : Msghdr;
       for GNAT_Msg'Address use Msg;
       pragma Import (Ada, GNAT_Msg);
 
-      VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
+      VMS_Msg : aliased VMS_Msghdr;
 
    begin
+      if VMS_V7 then
+         Msg_Addr := Msg;
+      else
+         VMS_Msg := VMS_Msghdr (GNAT_Msg);
+         Msg_Addr := VMS_Msg'Address;
+      end if;
+
       loop
-         Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags);
+         Res := Syscall_Sendmsg (S, Msg_Addr, Flags);
          exit when SOSC.Thread_Blocking_IO
            or else Res /= Failure
            or else Non_Blocking_Socket (S)
@@ -343,7 +371,9 @@ package body GNAT.Sockets.Thin is
          delay Quantum;
       end loop;
 
-      GNAT_Msg := Msghdr (VMS_Msg);
+      if not VMS_V7 then
+         GNAT_Msg := Msghdr (VMS_Msg);
+      end if;
 
       return System.CRTL.ssize_t (Res);
    end C_Sendmsg;
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 02771d5..0cf32e8 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -1749,6 +1749,8 @@ __gnat_set_features (void)
 
 /* Return true if the VMS version is 7.x.  */
 
+extern unsigned int LIB$GETSYI (int *, ...);
+
 #define SYI$_VERSION 0x1000
 
 int
@@ -1763,7 +1765,7 @@ __gnat_is_vms_v7 (void)
   desc.mbz = 0;
   desc.adr = version;
 
-  status = lib$getsyi (&code, 0, &desc);
+  status = LIB$GETSYI (&code, 0, &desc);
   if ((status & 1) == 1 && version[1] == '7' && version[2] == '.')
     return 1;
   else
diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb
index 9120ae7..8b86c46 100644
--- a/gcc/ada/prj-conf.adb
+++ b/gcc/ada/prj-conf.adb
@@ -436,6 +436,8 @@ package body Prj.Conf is
 
          Compiler := Create_Package (Project_Tree, Config_File, "compiler");
          Create_Attribute
+           (Name_Driver, "gcc", "ada", Pkg => Compiler);
+         Create_Attribute
            (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
          Create_Attribute
            (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 0fa421e..5761209 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -6766,8 +6766,13 @@ package body Prj.Nmsc is
                        & " kind=" & Source.Kind'Img);
       end if;
 
-      if Source.Kind in Spec_Or_Body and then Source.Unit /= null then
-         Source.Unit.File_Names (Source.Kind) := Source;
+      if Source.Unit /= null then
+         if Source.Kind = Spec then
+            Source.Unit.File_Names (Spec) := Source;
+
+         else
+            Source.Unit.File_Names (Impl) := Source;
+         end if;
       end if;
    end Override_Kind;
 
diff --git a/gcc/ada/put_alfa.adb b/gcc/ada/put_alfa.adb
index adb41a8..49dfac8 100644
--- a/gcc/ada/put_alfa.adb
+++ b/gcc/ada/put_alfa.adb
@@ -151,8 +151,8 @@ begin
                   Write_Info_Char (S.Scope_Name (N));
                end loop;
 
-               --  Default value of (0,0) is used for the special HEAP variable
-               --  so use another default value.
+               --  Default value of (0,0) is used for the special __HEAP
+               --  variable so use another default value.
 
                Entity_Line := 0;
                Entity_Col  := 1;
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 5919405..4b4e2ca 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -4956,6 +4956,20 @@ package body Sem_Ch6 is
                  ("subprogram & overrides inherited operation #", Spec, Subp);
             end if;
 
+         --  Special-case to fix a GNAT oddity:  Limited_Controlled is declared
+         --  as an extension of Root_Controlled, and thus has a useless Adjust
+         --  operation. This operation should not be inherited by other limited
+         --  controlled types. An explicit Adjust for them is not overriding.
+
+         elsif Must_Override (Spec)
+           and then Chars (Overridden_Subp) = Name_Adjust
+           and then Is_Limited_Type (Etype (First_Formal (Subp)))
+           and then Present (Alias (Overridden_Subp))
+           and then Is_Predefined_File_Name
+             (Unit_File_Name (Get_Source_Unit (Alias (Overridden_Subp))))
+         then
+            Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
+
          elsif Is_Subprogram (Subp) then
             if Is_Init_Proc (Subp) then
                null;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 8f5909f..27f4c8a 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -39,6 +39,7 @@ with Elists;   use Elists;
 with Errout;   use Errout;
 with Exp_Dist; use Exp_Dist;
 with Exp_Util; use Exp_Util;
+with Freeze;   use Freeze;
 with Lib;      use Lib;
 with Lib.Writ; use Lib.Writ;
 with Lib.Xref; use Lib.Xref;
@@ -261,6 +262,99 @@ package body Sem_Prag is
       Preanalyze_Spec_Expression
         (Get_Pragma_Arg (Arg1), Standard_Boolean);
 
+      if Class_Present (N) then
+         declare
+            T   : constant Entity_Id := Find_Dispatching_Type (S);
+
+            ACW : Entity_Id := Empty;
+            --  Access to T'class, created if there is a controlling formal
+            --  that is an access parameter.
+
+            function Get_ACW return Entity_Id;
+            --  If the expression has a reference to an controlling access
+            --  parameter, create an access to T'class for the necessary
+            --  conversions if one does not exist.
+
+            function Process (N : Node_Id) return Traverse_Result;
+            --  ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
+            --  aspect for a primitive subprogram of a tagged type T, a name
+            --  that denotes a formal parameter of type T is interpreted as
+            --  having type T'Class. Similarly, a name that denotes a formal
+            --  accessparameter of type access-to-T is interpreted as having
+            --  type access-to-T'Class. This ensures the expression is well-
+            --  defined for a primitive subprogram of a type descended from T.
+
+            -------------
+            -- Get_ACW --
+            -------------
+
+            function Get_ACW return Entity_Id is
+               Loc  : constant Source_Ptr := Sloc (N);
+               Decl : Node_Id;
+
+            begin
+               if No (ACW) then
+                  Decl := Make_Full_Type_Declaration (Loc,
+                    Defining_Identifier => Make_Temporary (Loc, 'T'),
+                    Type_Definition =>
+                       Make_Access_To_Object_Definition (Loc,
+                       Subtype_Indication =>
+                         New_Occurrence_Of (Class_Wide_Type (T), Loc),
+                       All_Present => True));
+
+                  Insert_Before (Unit_Declaration_Node (S), Decl);
+                  Analyze (Decl);
+                  ACW := Defining_Identifier (Decl);
+                  Freeze_Before (Unit_Declaration_Node (S), ACW);
+               end if;
+
+               return ACW;
+            end Get_ACW;
+
+            -------------
+            -- Process --
+            -------------
+
+            function Process (N : Node_Id) return Traverse_Result is
+               Loc : constant Source_Ptr := Sloc (N);
+               Typ : Entity_Id;
+
+            begin
+               if Is_Entity_Name (N)
+                 and then Is_Formal (Entity (N))
+                 and then Nkind (Parent (N)) /= N_Type_Conversion
+               then
+                  if Etype (Entity (N)) = T then
+                     Typ := Class_Wide_Type (T);
+
+                  elsif Is_Access_Type (Etype (Entity (N)))
+                    and then Designated_Type (Etype (Entity (N))) = T
+                  then
+                     Typ := Get_ACW;
+                  else
+                     Typ := Empty;
+                  end if;
+
+                  if Present (Typ) then
+                     Rewrite (N,
+                       Make_Type_Conversion (Loc,
+                         Subtype_Mark =>
+                           New_Occurrence_Of (Typ, Loc),
+                         Expression  => New_Occurrence_Of (Entity (N), Loc)));
+                     Set_Etype (N, Typ);
+                  end if;
+               end if;
+
+               return OK;
+            end Process;
+
+            procedure Replace_Type is new Traverse_Proc (Process);
+
+         begin
+            Replace_Type (Get_Pragma_Arg (Arg1));
+         end;
+      end if;
+
       --  Remove the subprogram from the scope stack now that the pre-analysis
       --  of the precondition/postcondition is done.
 
@@ -1838,6 +1932,12 @@ package body Sem_Prag is
                   Chain_PPC (PO);
                   return;
 
+               elsif Nkind (PO) = N_Subprogram_Declaration
+                 and then In_Instance
+               then
+                  Chain_PPC (PO);
+                  return;
+
                --  For all other cases of non source code, do nothing
 
                else
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 3fe0719..7668aa9 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3446,6 +3446,7 @@ package body Sem_Res is
               and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F)))
             then
                Establish_Transient_Scope (A, False);
+               Resolve (A, Etype (F));
 
             --  A small optimization: if one of the actuals is a concatenation
             --  create a block around a procedure call to recover stack space.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 658ca1a..23105c5 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12747,6 +12747,8 @@ package body Sem_Util is
       then
          return Get_Name_String (Name_Standard) & "__" &
            Get_Name_String (Chars (E));
+      elsif Ekind (E) = E_Enumeration_Literal then
+         return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
 
       else
          return Get_Scoped_Name (E);