OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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.

From-SVN: r150007
This commit is contained in:
Arnaud Charlet 2009-07-23 14:50:44 +02:00
parent c37845f841
commit ce14c57705
7 changed files with 137 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/ada/ChangeLog
View File

@ -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

123
gcc/ada/errout.adb
View File

@ -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)))

10
gcc/ada/exp_ch6.adb
View File

@ -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);

25
gcc/ada/freeze.adb
View File

@ -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

4
gcc/ada/gnat_ugn.texi
View File

@ -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.

1
gcc/ada/prj-nmsc.adb
View File

@ -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)

21
gcc/ada/sem_prag.adb
View File

@ -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));