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 + + * gnat_ugn.texi (Misnamed_Controlling_Parameters gnatcheck rule): Fix + misprint in rule description. + +2009-07-23 Gary Dismukes + + * 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 + + * freeze.adb, prj-nmsc.adb, errout.adb: Minor reformatting + Minor code reorganization + +2009-07-23 Arnaud Charlet + + * 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 * 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. + -- 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 = "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; + if Is_Type (E) + and then Is_Atomic (E) + and then No (Get_Rep_Pragma (E, Name_Atomic)) + then + return True; + end if; + + -- 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 - else - return False; - end if; + 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. + -- 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 Nkind (Parent (Object_Decl)) = N_Extended_Return_Statement then + 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));