2009-07-23 Sergey Rybin <rybin@adacore.com>

	* gnat_ugn.texi (Misnamed_Controlling_Parameters gnatcheck rule): Fix
	misprint in rule description.

2009-07-23  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Replace
	test that the object declaration is within an extended return statement
	with direct test of whether the declared object associated with the
	build-in-place call is a return object, since the enclosing function
	might not even be a build-in-place function.

2009-07-23  Robert Dewar  <dewar@adacore.com>

	* freeze.adb, prj-nmsc.adb, errout.adb: Minor reformatting
	Minor code reorganization

2009-07-23  Arnaud Charlet  <charlet@adacore.com>

	* sem_prag.adb (Analyze_Pragma): Do not ignore pragma Pack on records
	for static analysis, only packed arrays are causing troubles.



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

7 files changed, 139 insertions, 72 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index eddc1449dbe..3178b3e492a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,26 @@
+2009-07-23  Sergey Rybin  <rybin@adacore.com>
+
+	* gnat_ugn.texi (Misnamed_Controlling_Parameters gnatcheck rule): Fix
+	misprint in rule description.
+
+2009-07-23  Gary Dismukes  <dismukes@adacore.com>
+
+	* exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): Replace
+	test that the object declaration is within an extended return statement
+	with direct test of whether the declared object associated with the
+	build-in-place call is a return object, since the enclosing function
+	might not even be a build-in-place function.
+
+2009-07-23  Robert Dewar  <dewar@adacore.com>
+
+	* freeze.adb, prj-nmsc.adb, errout.adb: Minor reformatting
+	Minor code reorganization
+
+2009-07-23  Arnaud Charlet  <charlet@adacore.com>
+
+	* sem_prag.adb (Analyze_Pragma): Do not ignore pragma Pack on records
+	for static analysis, only packed arrays are causing troubles.
+
 2009-07-23  Gary Dismukes  <dismukes@adacore.com>
 
 	* sem_aggr.adb (Resolve_Extension_Aggregate): Report an error when the
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 12b491f4136..aa36a9ddaab 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -2693,9 +2693,9 @@ package body Errout is
 
          Set_Error_Posted (N);
 
-         --  If it is a subexpression, then set Error_Posted on parents
-         --  up to and including the first non-subexpression construct. This
-         --  helps avoid cascaded error messages within a single expression.
+         --  If it is a subexpression, then set Error_Posted on parents up to
+         --  and including the first non-subexpression construct. This helps
+         --  avoid cascaded error messages within a single expression.
 
          P := N;
          loop
@@ -2735,6 +2735,8 @@ package body Errout is
    -- Special_Msg_Delete --
    ------------------------
 
+   --  Is it really right to have all this specialized knowledge in errout?
+
    function Special_Msg_Delete
      (Msg : String;
       N   : Node_Or_Entity_Id;
@@ -2746,51 +2748,61 @@ package body Errout is
       if Debug_Flag_OO then
          return False;
 
-      --  When an atomic object refers to a non-atomic type in the same
-      --  scope, we implicitly make the type atomic. In the non-error
-      --  case this is surely safe (and in fact prevents an error from
-      --  occurring if the type is not atomic by default). But if the
-      --  object cannot be made atomic, then we introduce an extra junk
-      --  message by this manipulation, which we get rid of here.
+      --  Processing for "atomic access cannot be guaranteed"
 
-      --  We identify this case by the fact that it references a type for
-      --  which Is_Atomic is set, but there is no Atomic pragma setting it.
+      elsif Msg = "atomic access to & cannot be guaranteed" then
 
-      elsif Msg = "atomic access to & cannot be guaranteed"
-        and then Is_Type (E)
-        and then Is_Atomic (E)
-        and then No (Get_Rep_Pragma (E, Name_Atomic))
-      then
-         return True;
+         --  When an atomic object refers to a non-atomic type in the same
+         --  scope, we implicitly make the type atomic. In the non-error case
+         --  this is surely safe (and in fact prevents an error from occurring
+         --  if the type is not atomic by default). But if the object cannot be
+         --  made atomic, then we introduce an extra junk message by this
+         --  manipulation, which we get rid of here.
 
-      --  When a size is wrong for a frozen type there is no explicit
-      --  size clause, and other errors have occurred, suppress the
-      --  message, since it is likely that this size error is a cascaded
-      --  result of other errors. The reason we eliminate unfrozen types
-      --  is that messages issued before the freeze type are for sure OK.
-      --  Also suppress "size too small" errors in CodePeer mode, since pragma
-      --  Pack is also ignored in this configuration.
-
-      elsif Msg = "size for& too small, minimum allowed is ^"
-        and then (CodePeer_Mode
-          or else (Is_Frozen (E)
-            and then Serious_Errors_Detected > 0
-            and then Nkind (N) /= N_Component_Clause
-            and then Nkind (Parent (N)) /= N_Component_Clause
-            and then
-              No (Get_Attribute_Definition_Clause (E, Attribute_Size))
-            and then
-              No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
-            and then
-              No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))))
-      then
-         return True;
+         --  We identify this case by the fact that it references a type for
+         --  which Is_Atomic is set, but there is no Atomic pragma setting it.
 
-      --  All special tests complete, so go ahead with message
+         if Is_Type (E)
+           and then Is_Atomic (E)
+           and then No (Get_Rep_Pragma (E, Name_Atomic))
+         then
+            return True;
+         end if;
 
-      else
-         return False;
+      --  Processing for "Size too small" messages
+
+      elsif Msg = "size for& too small, minimum allowed is ^" then
+
+         --  Suppress "size too small" errors in CodePeer mode, since pragma
+         --  Pack is also ignored in this configuration.
+
+         if CodePeer_Mode then
+            return True;
+
+         --  When a size is wrong for a frozen type there is no explicit size
+         --  clause, and other errors have occurred, suppress the message,
+         --  since it is likely that this size error is a cascaded result of
+         --  other errors. The reason we eliminate unfrozen types is that
+         --  messages issued before the freeze type are for sure OK.
+
+         elsif Is_Frozen (E)
+           and then Serious_Errors_Detected > 0
+           and then Nkind (N) /= N_Component_Clause
+           and then Nkind (Parent (N)) /= N_Component_Clause
+           and then
+             No (Get_Attribute_Definition_Clause (E, Attribute_Size))
+           and then
+             No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
+           and then
+             No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
+         then
+            return True;
+         end if;
       end if;
+
+      --  All special tests complete, so go ahead with message
+
+      return False;
    end Special_Msg_Delete;
 
    --------------------------
@@ -2811,18 +2823,18 @@ package body Errout is
          Msglen := Msglen - 1;
       end if;
 
-      --  The loop here deals with recursive types, we are trying to
-      --  find a related entity that is not an implicit type. Note
-      --  that the check with Old_Ent stops us from getting "stuck".
-      --  Also, we don't output the "type derived from" message more
-      --  than once in the case where we climb up multiple levels.
+      --  The loop here deals with recursive types, we are trying to find a
+      --  related entity that is not an implicit type. Note that the check with
+      --  Old_Ent stops us from getting "stuck". Also, we don't output the
+      --  "type derived from" message more than once in the case where we climb
+      --  up multiple levels.
 
       loop
          Old_Ent := Ent;
 
-         --  Implicit access type, use directly designated type
-         --  In Ada 2005, the designated type may be an anonymous access to
-         --  subprogram, in which case we can only point to its definition.
+         --  Implicit access type, use directly designated type In Ada 2005,
+         --  the designated type may be an anonymous access to subprogram, in
+         --  which case we can only point to its definition.
 
          if Is_Access_Type (Ent) then
             if Ekind (Ent) = E_Access_Subprogram_Type
@@ -2874,13 +2886,12 @@ package body Errout is
 
             Ent := Base_Type (Ent);
 
-         --  If this is a base type with a first named subtype, use the
-         --  first named subtype instead. This is not quite accurate in
-         --  all cases, but it makes too much noise to be accurate and
-         --  add 'Base in all cases. Note that we only do this is the
-         --  first named subtype is not itself an internal name. This
-         --  avoids the obvious loop (subtype->basetype->subtype) which
-         --  would otherwise occur!)
+         --  If this is a base type with a first named subtype, use the first
+         --  named subtype instead. This is not quite accurate in all cases,
+         --  but it makes too much noise to be accurate and add 'Base in all
+         --  cases. Note that we only do this is the first named subtype is not
+         --  itself an internal name. This avoids the obvious loop (subtype ->
+         --  basetype -> subtype) which would otherwise occur!)
 
          elsif Present (Freeze_Node (Ent))
            and then Present (First_Subtype_Link (Freeze_Node (Ent)))
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index dfcf37c7d51..83196ec9caf 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5557,9 +5557,15 @@ package body Exp_Ch6 is
       --  If the function's result subtype is unconstrained and the object is
       --  a return object of an enclosing build-in-place function, then the
       --  implicit build-in-place parameters of the enclosing function must be
-      --  passed along to the called function.
-
-      elsif Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement then
+      --  passed along to the called function. (Unfortunately, this won't cover
+      --  the case of extension aggregates where the ancestor part is a build-
+      --  in-place unconstrained function call that should be passed along the
+      --  caller's parameters. Currently those get mishandled by reassigning
+      --  the result of the call to the aggregate return object, when the call
+      --  result should really be directly built in place in the aggregate and
+      --  not built in a temporary. ???)
+
+      elsif Is_Return_Object (Defining_Identifier (Object_Decl)) then
          Pass_Caller_Acc := True;
 
          Enclosing_Func := Enclosing_Subprogram (Obj_Def_Id);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 9cd87581fb0..14ba41c9956 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -2280,15 +2280,38 @@ package body Freeze is
             end;
          end if;
 
-         --  See if Implicit_Packing would work
+         --  See if Size is too small as is (and implicit packing might help)
 
          if not Is_Packed (Rec)
+
+           --  No implicit packing if even one component is explicitly placed
+
            and then not Placed_Component
+
+           --  Must have size clause and all scalar components
+
            and then Has_Size_Clause (Rec)
            and then All_Scalar_Components
+
+           --  Do not try implicit packing on records with discriminants, too
+           --  complicated, especially in the variant record case.
+
            and then not Has_Discriminants (Rec)
+
+           --  We can implicitly pack if the specified size of the record is
+           --  less than the sum of the object sizes (no point in packing if
+           --  this is not the case).
+
            and then Esize (Rec) < Scalar_Component_Total_Esize
+
+           --  And the total RM size cannot be greater than the specified size
+           --  since otherwise packing will not get us where we have to be!
+
            and then Esize (Rec) >= Scalar_Component_Total_RM_Size
+
+           --  Never do implicit packing in CodePeer mode since we don't do
+           --  any packing ever in this mode (why not???)
+
            and then not CodePeer_Mode
          then
             --  If implicit packing enabled, do it
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index c3cc5697394..c2bcfbefe49 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -1,4 +1,4 @@
-\input texinfo   @c -*-texinfo-*-
+f\input texinfo   @c -*-texinfo-*-
 @c %**start of header
 
 @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
@@ -21821,7 +21821,7 @@ not a controlling one and its name is not @code{This} (the check for
 parameter name is not case-sensitive). Declarations of dispatching functions
 with controlling result and no controlling parameter are never flagged.
 
-A subprogram body declaration, subprogram renaming declaration of subprogram
+A subprogram body declaration, subprogram renaming declaration or subprogram
 body stub is flagged only if it is not a completion of a prior subprogram
 declaration.
 
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index df29bb55d50..f0ded903ff9 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -498,6 +498,7 @@ package body Prj.Nmsc is
 
       begin
          --  On non case-sensitive systems, use proper suffix casing
+
          Canonical_Case_File_Name (Suf);
 
          --  The file name must end with the suffix (which is not an extension)
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 4b4da5fbaa5..902cb30e825 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -9508,15 +9508,23 @@ package body Sem_Prag is
 
                else
                   if not Rep_Item_Too_Late (Typ, N) then
+
+                     --  In the context of static code analysis, we do not need
+                     --  complex front-end expansions related to pragma Pack,
+                     --  so disable handling of pragma Pack in this case.
+
                      if CodePeer_Mode then
-                        --  Ignore pragma Pack and disable corresponding
-                        --  complex expansions in CodePeer mode
                         null;
 
+                     --  For normal non-VM target, do the packing
+
                      elsif VM_Target = No_VM then
                         Set_Is_Packed            (Base_Type (Typ));
                         Set_Has_Pragma_Pack      (Base_Type (Typ));
-                        Set_Has_Non_Standard_Rep (Base_Type (Typ));
+                           Set_Has_Non_Standard_Rep (Base_Type (Typ));
+
+                     --  If we ignore the pack, then warn about this, except
+                     --  that we suppress the warning in GNAT mode.
 
                      elsif not GNAT_Mode then
                         Error_Pragma
@@ -9529,12 +9537,7 @@ package body Sem_Prag is
 
             else pragma Assert (Is_Record_Type (Typ));
                if not Rep_Item_Too_Late (Typ, N) then
-                  if CodePeer_Mode then
-                     --  Ignore pragma Pack and disable corresponding
-                     --  complex expansions in CodePeer mode
-                     null;
-
-                  elsif VM_Target = No_VM then
+                  if VM_Target = No_VM then
                      Set_Is_Packed            (Base_Type (Typ));
                      Set_Has_Pragma_Pack      (Base_Type (Typ));
                      Set_Has_Non_Standard_Rep (Base_Type (Typ));