2009-05-06 Robert Dewar <dewar@adacore.com>

	* freeze.adb (Freeze_Record_Type): Improve error msg for bad size
	clause.

2009-05-06  Thomas Quinot  <quinot@adacore.com>

	* g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate
	packed type, since on OpenVMS, struct msghdr is packed.

2009-05-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Object_Renaming): If the object is a function
	call returning an unconstrained composite value, create the proper
	subtype for it, as is done for object dclarations with unconstrained
	nominal subtypes. Perform this transformation regarless of whether
	call comes from source.



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

4 files changed, 96 insertions, 46 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4283d89449e..bb3f3a3453f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,5 +1,23 @@
 2009-05-06  Robert Dewar  <dewar@adacore.com>
 
+	* freeze.adb (Freeze_Record_Type): Improve error msg for bad size
+	clause.
+
+2009-05-06  Thomas Quinot  <quinot@adacore.com>
+
+	* g-socthi-vms.adb (C_Recvmsg, C_Sendmsg): Convert Msg to appropriate
+	packed type, since on OpenVMS, struct msghdr is packed.
+
+2009-05-06  Ed Schonberg  <schonberg@adacore.com>
+
+	* sem_ch8.adb (Analyze_Object_Renaming): If the object is a function
+	call returning an unconstrained composite value, create the proper
+	subtype for it, as is done for object dclarations with unconstrained
+	nominal subtypes. Perform this transformation regarless of whether
+	call comes from source.
+
+2009-05-06  Robert Dewar  <dewar@adacore.com>
+
 	* freeze.adb (Freeze_Record_Type): Implement Implicit_Packing for
 	records
 
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index fa27be545a7..1f91db98388 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -1864,17 +1864,15 @@ package body Freeze is
                end;
             end if;
 
-            --  Processing for possible Implicit_Packing later
+            --  Gather data for possible Implicit_Packing later
 
-            if Implicit_Packing then
-               if not Is_Scalar_Type (Etype (Comp)) then
-                  All_Scalar_Components := False;
-               else
-                  Scalar_Component_Total_RM_Size :=
-                    Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
-                  Scalar_Component_Total_Esize :=
-                    Scalar_Component_Total_Esize + Esize (Etype (Comp));
-               end if;
+            if not Is_Scalar_Type (Etype (Comp)) then
+               All_Scalar_Components := False;
+            else
+               Scalar_Component_Total_RM_Size :=
+                 Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
+               Scalar_Component_Total_Esize :=
+                 Scalar_Component_Total_Esize + Esize (Etype (Comp));
             end if;
 
             --  If the component is an Itype with Delayed_Freeze and is either
@@ -2186,16 +2184,34 @@ package body Freeze is
             end;
          end if;
 
-         --  Apply implicit packing if all conditions are met
+         --  See if Implicit_Packing would work
 
-         if Implicit_Packing
+         if not Is_Packed (Rec)
+           and then not Placed_Component
            and then Has_Size_Clause (Rec)
            and then All_Scalar_Components
            and then not Has_Discriminants (Rec)
            and then Esize (Rec) < Scalar_Component_Total_Esize
            and then Esize (Rec) >= Scalar_Component_Total_RM_Size
          then
-            Set_Is_Packed (Rec);
+            --  If implicit packing enabled, do it
+
+            if Implicit_Packing then
+               Set_Is_Packed (Rec);
+
+               --  Otherwise flag the size clause
+
+            else
+               declare
+                  Sz : constant Node_Id := Size_Clause (Rec);
+               begin
+                  Error_Msg_NE
+                    ("size given for& too small", Sz, Rec);
+                  Error_Msg_N
+                    ("\use explicit pragma Pack "
+                     & "or use pragma Implicit_Packing", Sz);
+               end;
+            end if;
          end if;
       end Freeze_Record_Type;
 
diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb
index 696a298004c..20855c040fd 100644
--- a/gcc/ada/g-socthi-vms.adb
+++ b/gcc/ada/g-socthi-vms.adb
@@ -40,6 +40,11 @@ with Interfaces.C; use Interfaces.C;
 
 package body GNAT.Sockets.Thin is
 
+   type VMS_Msghdr is new Msghdr;
+   pragma Pack (VMS_Msghdr);
+   --  On VMS (unlike other platforms), struct msghdr is packed, so a specific
+   --  derived type is required.
+
    Non_Blocking_Sockets : aliased Fd_Set;
    --  When this package is initialized with Process_Blocking_IO set to True,
    --  sockets are set in non-blocking mode to avoid blocking the whole process
@@ -300,15 +305,21 @@ package body GNAT.Sockets.Thin is
    is
       Res : C.int;
 
+      GNAT_Msg : Msghdr;
+      for GNAT_Msg'Address use Msg;
+      pragma Import (Ada, GNAT_Msg);
+
+      VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
    begin
       loop
-         Res := Syscall_Recvmsg (S, Msg, Flags);
+         Res := Syscall_Recvmsg (S, VMS_Msg'Address, Flags);
          exit when SOSC.Thread_Blocking_IO
            or else Res /= Failure
            or else Non_Blocking_Socket (S)
            or else Errno /= SOSC.EWOULDBLOCK;
          delay Quantum;
       end loop;
+      GNAT_Msg := Msghdr (VMS_Msg);
 
       return ssize_t (Res);
    end C_Recvmsg;
@@ -324,15 +335,22 @@ package body GNAT.Sockets.Thin is
    is
       Res : C.int;
 
+      GNAT_Msg : Msghdr;
+      for GNAT_Msg'Address use Msg;
+      pragma Import (Ada, GNAT_Msg);
+
+      VMS_Msg : aliased VMS_Msghdr := VMS_Msghdr (GNAT_Msg);
+
    begin
       loop
-         Res := Syscall_Sendmsg (S, Msg, Flags);
+         Res := Syscall_Sendmsg (S, VMS_Msg'Address, Flags);
          exit when SOSC.Thread_Blocking_IO
            or else Res /= Failure
            or else Non_Blocking_Socket (S)
            or else Errno /= SOSC.EWOULDBLOCK;
          delay Quantum;
       end loop;
+      GNAT_Msg := Msghdr (VMS_Msg);
 
       return ssize_t (Res);
    end C_Sendmsg;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 9b9f841679d..42bbd25a710 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -866,42 +866,43 @@ package body Sem_Ch8 is
          end if;
       end if;
 
-      --  Special processing for renaming function return object
+      --  Special processing for renaming function return object. Some errors
+      --  and warnings are produced only for calls that come from source.
 
-      if Nkind (Nam) = N_Function_Call
-        and then Comes_From_Source (Nam)
-      then
+      if Nkind (Nam) = N_Function_Call then
          case Ada_Version is
 
             --  Usage is illegal in Ada 83
 
             when Ada_83 =>
-               Error_Msg_N
-                 ("(Ada 83) cannot rename function return object", Nam);
+               if Comes_From_Source (Nam) then
+                  Error_Msg_N
+                    ("(Ada 83) cannot rename function return object", Nam);
+               end if;
 
             --  In Ada 95, warn for odd case of renaming parameterless function
-            --  call if this is not a limited type (where this is useful)
+            --  call if this is not a limited type (where this is useful).
 
             when others =>
                if Warn_On_Object_Renames_Function
                  and then No (Parameter_Associations (Nam))
                  and then not Is_Limited_Type (Etype (Nam))
+                 and then Comes_From_Source (Nam)
                then
                   Error_Msg_N
-                    ("?renaming function result object is suspicious",
-                     Nam);
+                    ("?renaming function result object is suspicious", Nam);
                   Error_Msg_NE
-                    ("\?function & will be called only once",
-                     Nam, Entity (Name (Nam)));
+                    ("\?function & will be called only once", Nam,
+                     Entity (Name (Nam)));
                   Error_Msg_N
                     ("\?suggest using an initialized constant object instead",
                      Nam);
                end if;
 
-               --  If the function call returns an unconstrained type, we
-               --  must build a constrained subtype for the new entity, in
-               --  a way similar to what is done for an object declaration
-               --  with an unconstrained nominal type.
+               --  If the function call returns an unconstrained type, we must
+               --  build a constrained subtype for the new entity, in a way
+               --  similar to what is done for an object declaration with an
+               --  unconstrained nominal type.
 
                if Is_Composite_Type (Etype (Nam))
                  and then not Is_Constrained (Etype (Nam))
@@ -945,6 +946,7 @@ package body Sem_Ch8 is
       then
          Error_Msg_NE ("invalid use of incomplete type&", Id, T2);
          return;
+
       elsif Ekind (Etype (T)) = E_Incomplete_Type then
          Error_Msg_NE ("invalid use of incomplete type&", Id, T);
          return;
@@ -962,8 +964,8 @@ package body Sem_Ch8 is
         and then Nkind (Nam) in N_Has_Entity
       then
          declare
-            Nam_Decl    : Node_Id;
-            Nam_Ent     : Entity_Id;
+            Nam_Decl : Node_Id;
+            Nam_Ent  : Entity_Id;
 
          begin
             if Nkind (Nam) = N_Attribute_Reference then
@@ -972,7 +974,7 @@ package body Sem_Ch8 is
                Nam_Ent := Entity (Nam);
             end if;
 
-            Nam_Decl    := Parent (Nam_Ent);
+            Nam_Decl := Parent (Nam_Ent);
 
             if Has_Null_Exclusion (N)
               and then not Has_Null_Exclusion (Nam_Decl)
@@ -985,7 +987,7 @@ package body Sem_Ch8 is
                --  have a null exclusion or a null-excluding subtype.
 
                if Is_Formal_Object (Nam_Ent)
-                 and then In_Generic_Scope (Id)
+                    and then In_Generic_Scope (Id)
                then
                   if not Can_Never_Be_Null (Etype (Nam_Ent)) then
                      Error_Msg_N
@@ -1012,11 +1014,11 @@ package body Sem_Ch8 is
                --  of the renamed actual in the instance will raise
                --  constraint_error.
 
-               elsif Nkind (Parent (Nam_Ent)) = N_Object_Declaration
+               elsif Nkind (Nam_Decl) = N_Object_Declaration
                  and then In_Instance
                  and then Present
-                   (Corresponding_Generic_Association (Parent (Nam_Ent)))
-                 and then Nkind (Expression (Parent (Nam_Ent)))
+                   (Corresponding_Generic_Association (Nam_Decl))
+                 and then Nkind (Expression (Nam_Decl))
                    = N_Raise_Constraint_Error
                then
                   Error_Msg_N
@@ -1027,7 +1029,7 @@ package body Sem_Ch8 is
                --  must not be null-excluding.
 
                elsif No (Access_Definition (N))
-                 and then  Can_Never_Be_Null (T)
+                 and then Can_Never_Be_Null (T)
                then
                   Error_Msg_NE
                     ("`NOT NULL` not allowed (& already excludes null)",
@@ -1067,8 +1069,6 @@ package body Sem_Ch8 is
          then
             Error_Msg_N
               ("illegal renaming of discriminant-dependent component", Nam);
-         else
-            null;
          end if;
 
       --  A static function call may have been folded into a literal
@@ -1143,8 +1143,7 @@ package body Sem_Ch8 is
          return;
       end if;
 
-      --  Apply Text_IO kludge here, since we may be renaming one of the
-      --  children of Text_IO.
+      --  Apply Text_IO kludge here since we may be renaming a child of Text_IO
 
       Text_IO_Kludge (Name (N));
 
@@ -1162,8 +1161,7 @@ package body Sem_Ch8 is
       end if;
 
       if Etype (Old_P) = Any_Type then
-         Error_Msg_N
-           ("expect package name in renaming", Name (N));
+         Error_Msg_N ("expect package name in renaming", Name (N));
 
       elsif Ekind (Old_P) /= E_Package
         and then not (Ekind (Old_P) = E_Generic_Package
@@ -1400,8 +1398,8 @@ package body Sem_Ch8 is
 
          Inherit_Renamed_Profile (New_S, Old_S);
 
-         --  The prefix can be an arbitrary expression that yields a task
-         --  type, so it must be resolved.
+         --  The prefix can be an arbitrary expression that yields a task type,
+         --  so it must be resolved.
 
          Resolve (Prefix (Nam), Scope (Old_S));
       end if;