mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-16 03:10:28 +08:00
Code Issues Packages Projects Releases Wiki Activity

sem_res.adb (Analyze_Indexed_Component, [...]): Warn on assigning to packed atomic component.

Browse Source 
2010-06-18  Robert Dewar  <dewar@adacore.com>

	* sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component):
	Warn on assigning to packed atomic component.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* sem_util.ads: Minor reformatting
	* einfo.ads, einfo.adb: Minor doc clarification (scope of decls in
	Expression_With_Actions).
	* snames.ads-tmpl: Minor comment fix

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Diagnose_Multiple_Pragmas): New procedure
	(Set_Imported): Use Import_Interface_Present to control message output
	* sinfo.ads, sinfo.adb (Import_Interface_Present): New flag
	* gnat_rm.texi: Document that we can have pragma Import and pragma
	Interface for the same subprogram.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* lib-xref.adb (Generate_Reference): Fix bad reference to
	Has_Pragma_Unreferenced (clients should always use Has_Unreferenced).

From-SVN: r160961
This commit is contained in:
Robert Dewar 2010-06-18 08:17:48 +00:00 committed by Arnaud Charlet
parent 8ccfe1ab79
commit c28408b784
11 changed files with 299 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2010-06-18 Robert Dewar <dewar@adacore.com>
* sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component):
Warn on assigning to packed atomic component.
2010-06-18 Robert Dewar <dewar@adacore.com>
* sem_util.ads: Minor reformatting
* einfo.ads, einfo.adb: Minor doc clarification (scope of decls in
Expression_With_Actions).
* snames.ads-tmpl: Minor comment fix
2010-06-18 Robert Dewar <dewar@adacore.com>
* sem_prag.adb (Diagnose_Multiple_Pragmas): New procedure
(Set_Imported): Use Import_Interface_Present to control message output
* sinfo.ads, sinfo.adb (Import_Interface_Present): New flag
* gnat_rm.texi: Document that we can have pragma Import and pragma
Interface for the same subprogram.
2010-06-18 Robert Dewar <dewar@adacore.com>
* lib-xref.adb (Generate_Reference): Fix bad reference to
Has_Pragma_Unreferenced (clients should always use Has_Unreferenced).
2010-06-17 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (set_gnu_expr_location_from_node): New static

2
gcc/ada/einfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --

4
gcc/ada/einfo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -5209,7 +5209,7 @@ package Einfo is
-- Spec_PPC_List (Node24)
-- Interface_Alias (Node25)
-- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26)
-- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Body_Needed_For_SAL (Flag40)

7
gcc/ada/gnat_rm.texi
View File

@ -2856,7 +2856,12 @@ the standard Ada pragma @code{Import}. It is provided for compatibility
with Ada 83. The definition is upwards compatible both with pragma
@code{Interface} as defined in the Ada 83 Reference Manual, and also
with some extended implementations of this pragma in certain Ada 83
implementations.
implementations. The only difference between pragma @code{Interface}
and pragma @code{Import} is that there is special circuitry to allow
both pragmas to appear for the same subprogram entity (normally it
is illegal to have multiple @code{Import} pragmas. This is useful in
maintaining Ada 83/Ada 95 compatibility and is compatible with other
Ada 83 compilers.
@node Pragma Interface_Name
@unnumberedsec Pragma Interface_Name

4
gcc/ada/lib-xref.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -666,7 +666,7 @@ package body Lib.Xref is
-- Check for pragma Unreferenced given and reference is within
-- this source unit (occasion for possible warning to be issued).
if Has_Pragma_Unreferenced (E)
if Has_Unreferenced (E)
and then In_Same_Extended_Unit (E, N)
then
-- A reference as a named parameter in a call does not count

182
gcc/ada/sem_prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -2346,12 +2346,176 @@ package body Sem_Prag is
Cname : Name_Id;
Comp_Unit : Unit_Number_Type;
procedure Diagnose_Multiple_Pragmas (S : Entity_Id);
-- Called if we have more than one Export/Import/Convention pragma.
-- This is generally illegal, but we have a special case of allowing
-- Import and Interface to coexist if they specify the convention in
-- a consistent manner. We are allowed to do this, since Interface is
-- an implementation defined pragma, and we choose to do it since we
-- know Rational allows this combination. S is the entity id of the
-- subprogram in question. This procedure also sets the special flag
-- Import_Interface_Present in both pragmas in the case where we do
-- have matching Import and Interface pragmas.
procedure Set_Convention_From_Pragma (E : Entity_Id);
-- Set convention in entity E, and also flag that the entity has a
-- convention pragma. If entity is for a private or incomplete type,
-- also set convention and flag on underlying type. This procedure
-- also deals with the special case of C_Pass_By_Copy convention.
-------------------------------
-- Diagnose_Multiple_Pragmas --
-------------------------------
procedure Diagnose_Multiple_Pragmas (S : Entity_Id) is
Pdec : constant Node_Id := Declaration_Node (S);
Decl : Node_Id;
Err : Boolean;
function Same_Convention (Decl : Node_Id) return Boolean;
-- Decl is a pragma node. This function returns True if this
-- pragma has a first argument that is an identifier with a
-- Chars field corresponding to the Convention_Id C.
function Same_Name (Decl : Node_Id) return Boolean;
-- Decl is a pragma node. This function returns True if this
-- pragma has a second argument that is an identifier with a
-- Chars field that matches the Chars of the current subprogram.
---------------------
-- Same_Convention --
---------------------
function Same_Convention (Decl : Node_Id) return Boolean is
Arg1 : constant Node_Id :=
First (Pragma_Argument_Associations (Decl));
begin
if Present (Arg1) then
declare
Arg : constant Node_Id := Get_Pragma_Arg (Arg1);
begin
if Nkind (Arg) = N_Identifier
and then Is_Convention_Name (Chars (Arg))
and then Get_Convention_Id (Chars (Arg)) = C
then
return True;
end if;
end;
end if;
return False;
end Same_Convention;
---------------
-- Same_Name --
---------------
function Same_Name (Decl : Node_Id) return Boolean is
Arg1 : constant Node_Id :=
First (Pragma_Argument_Associations (Decl));
Arg2 : Node_Id;
begin
if No (Arg1) then
return False;
end if;
Arg2 := Next (Arg1);
if No (Arg2) then
return False;
end if;
declare
Arg : constant Node_Id := Get_Pragma_Arg (Arg2);
begin
if Nkind (Arg) = N_Identifier
and then Chars (Arg) = Chars (S)
then
return True;
end if;
end;
return False;
end Same_Name;
-- Start of processing for Diagnose_Multiple_Pragmas
begin
Err := True;
-- Definitely give message if we have Convention/Export here
if Prag_Id = Pragma_Convention or else Prag_Id = Pragma_Export then
null;
-- If we have an Import or Export, scan back from pragma to
-- find any previous pragma applying to the same procedure.
-- The scan will be terminated by the start of the list, or
-- hitting the subprogram declaration. This won't allow one
-- pragma to appear in the public part and one in the private
-- part, but that seems very unlikely in practice.
else
Decl := Prev (N);
while Present (Decl) and then Decl /= Pdec loop
-- Look for pragma with same name as us
if Nkind (Decl) = N_Pragma
and then Same_Name (Decl)
then
-- Give error if same as our pragma or Export/Convention
if Pragma_Name (Decl) = Name_Export
or else
Pragma_Name (Decl) = Name_Convention
or else
Pragma_Name (Decl) = Pragma_Name (N)
then
exit;
-- Case of Import/Interface or the other way round
elsif Pragma_Name (Decl) = Name_Interface
or else
Pragma_Name (Decl) = Name_Import
then
-- Here we know that we have Import and Interface. It
-- doesn't matter which way round they are. See if
-- they specify the same convention. If so, all OK,
-- and set special flags to stop other messages
if Same_Convention (Decl) then
Set_Import_Interface_Present (N);
Set_Import_Interface_Present (Decl);
Err := False;
-- If different conventions, special message
else
Error_Msg_Sloc := Sloc (Decl);
Error_Pragma_Arg
("convention differs from that given#", Arg1);
return;
end if;
end if;
end if;
Next (Decl);
end loop;
end if;
-- Give message if needed if we fall through those tests
if Err then
Error_Pragma_Arg
("at most one Convention/Export/Import pragma is allowed",
Arg2);
end if;
end Diagnose_Multiple_Pragmas;
--------------------------------
-- Set_Convention_From_Pragma --
--------------------------------
@ -2545,8 +2709,7 @@ package body Sem_Prag is
end if;
if Has_Convention_Pragma (E) then
Error_Pragma_Arg
("at most one Convention/Export/Import pragma is allowed", Arg2);
Diagnose_Multiple_Pragmas (E);
elsif Convention (E) = Convention_Protected
or else Ekind (Scope (E)) = E_Protected_Type
@ -4674,8 +4837,19 @@ package body Sem_Prag is
-- Error message if already imported or exported
if Is_Exported (E) or else Is_Imported (E) then
-- Error if being set Exported twice
if Is_Exported (E) then
Error_Msg_NE ("entity& was previously exported", N, E);
-- OK if Import/Interface case
elsif Import_Interface_Present (N) then
goto OK;
-- Error if being set Imported twice
else
Error_Msg_NE ("entity& was previously imported", N, E);
end if;
@ -4704,6 +4878,8 @@ package body Sem_Prag is
Set_Is_Statically_Allocated (E);
end if;
end if;
<<OK>> null;
end Set_Imported;
-------------------------

38
gcc/ada/sem_res.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -6635,6 +6635,24 @@ package body Sem_Res is
Warn_On_Suspicious_Index (Name, First (Expressions (N)));
Eval_Indexed_Component (N);
end if;
-- If the array type is atomic, and is packed, and we are in a left side
-- context, then this is worth a warning, since we have a situation
-- where the access to the component may cause extra read/writes of
-- the atomic array object, which could be considered unexpected.
if Nkind (N) = N_Indexed_Component
and then (Is_Atomic (Array_Type)
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Bit_Packed_Array (Array_Type)
and then Is_LHS (N)
then
Error_Msg_N ("?assignment to component of packed atomic array",
Prefix (N));
Error_Msg_N ("?\may cause unexpected accesses to atomic object",
Prefix (N));
end if;
end Resolve_Indexed_Component;
-----------------------------
@ -7715,7 +7733,6 @@ package body Sem_Res is
Comp := Next_Entity (Comp);
end loop;
end if;
Get_Next_Interp (I, It);
@ -7784,6 +7801,23 @@ package body Sem_Res is
-- Note: No Eval processing is required, because the prefix is of a
-- record type, or protected type, and neither can possibly be static.
-- If the array type is atomic, and is packed, and we are in a left side
-- context, then this is worth a warning, since we have a situation
-- where the access to the component may cause extra read/writes of
-- the atomic array object, which could be considered unexpected.
if Nkind (N) = N_Selected_Component
and then (Is_Atomic (T)
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Packed (T)
and then Is_LHS (N)
then
Error_Msg_N ("?assignment to component of packed atomic record",
Prefix (N));
Error_Msg_N ("?\may cause unexpected accesses to atomic object",
Prefix (N));
end if;
end Resolve_Selected_Component;
-------------------

4
gcc/ada/sem_util.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -712,7 +712,7 @@ package Sem_Util is
-- by a derived type declarations.
function Is_LHS (N : Node_Id) return Boolean;
-- Returns True iff N is used as Name in an assignment statement.
-- Returns True iff N is used as Name in an assignment statement
function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
-- A library-level declaration is one that is accessible from Standard,

18
gcc/ada/sinfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1557,6 +1557,14 @@ package body Sinfo is
return Flag16 (N);
end Interface_Present;
function Import_Interface_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Pragma);
return Flag16 (N);
end Import_Interface_Present;
function In_Present
(N : Node_Id) return Boolean is
begin
@ -4461,6 +4469,14 @@ package body Sinfo is
Set_Flag16 (N, Val);
end Set_Interface_Present;
procedure Set_Import_Interface_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Pragma);
Set_Flag16 (N, Val);
end Set_Import_Interface_Present;
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True) is
begin

26
gcc/ada/sinfo.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1172,6 +1172,11 @@ package Sinfo is
-- 'Address or 'Tag attribute. ???There are other implicit with clauses
-- as well.
-- Import_Interface_Present (Flag16-Sem)
-- This flag is set in an Interface or Import pragma if a matching
-- pragma of the other kind is also present. This is used to avoid
-- generating some unwanted error messages.
-- Includes_Infinities (Flag11-Sem)
-- This flag is present in N_Range nodes. It is set for the range of
-- unconstrained float types defined in Standard, which include not only
@ -1999,6 +2004,7 @@ package Sinfo is
-- Pragma_Identifier (Node4)
-- Next_Rep_Item (Node5-Sem)
-- Pragma_Enabled (Flag5-Sem)
-- Import_Interface_Present (Flag16-Sem)
-- Note: we should have a section on what pragmas are passed on to
-- the back end to be processed. This section should note that pragma
@ -6620,7 +6626,9 @@ package Sinfo is
-- actions associated with the right hand operand.
-- The N_Expression_With_Actions node represents an expression with
-- an associated set of actions (which are executable statements).
-- an associated set of actions (which are executable statements and
-- declarations, as might occur in a handled statement sequence).
-- The required semantics is that the set of actions is executed in
-- the order in which it appears just before the expression is
-- evaluated (and these actions must only be executed if the value
@ -6628,6 +6636,12 @@ package Sinfo is
-- a subexpression, whose value is the value of the Expression after
-- executing all the actions.
-- Note: if the actions contain declarations, then these declarations
-- maybe referenced with in the expression. It is thus appropriate for
-- the back end to create a scope that encompasses the construct (any
-- declarations within the actions will definitely not be referenced
-- once elaboration of the construct is completed).
-- Sprint syntax: do
-- action;
-- action;
@ -8151,6 +8165,9 @@ package Sinfo is
function Implicit_With
(N : Node_Id) return Boolean; -- Flag16
function Import_Interface_Present
(N : Node_Id) return Boolean; -- Flag16
function In_Present
(N : Node_Id) return Boolean; -- Flag15
@ -9078,6 +9095,9 @@ package Sinfo is
procedure Set_Implicit_With
(N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_Import_Interface_Present
(N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
@ -11384,6 +11404,7 @@ package Sinfo is
pragma Inline (Interface_List);
pragma Inline (Interface_Present);
pragma Inline (Includes_Infinities);
pragma Inline (Import_Interface_Present);
pragma Inline (In_Present);
pragma Inline (Inherited_Discriminant);
pragma Inline (Instance_Spec);
@ -11689,6 +11710,7 @@ package Sinfo is
pragma Inline (Set_Includes_Infinities);
pragma Inline (Set_Interface_List);
pragma Inline (Set_Interface_Present);
pragma Inline (Set_Import_Interface_Present);
pragma Inline (Set_In_Present);
pragma Inline (Set_Inherited_Discriminant);
pragma Inline (Set_Instance_Spec);

9
gcc/ada/snames.ads-tmpl
View File

@ -6,7 +6,7 @@
-- --
-- T e m p l a t e --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -1690,9 +1690,10 @@ package Snames is
-- call this function with a name that is not the name of a attribute.
function Get_Convention_Id (N : Name_Id) return Convention_Id;
-- Returns Id of language convention corresponding to given name. It is an
-- to call this function with a name that is not the name of a convention,
-- or one previously given in a call to Record_Convention_Identifier.
-- Returns Id of language convention corresponding to given name. It is
-- an error to call this function with a name that is not the name of a
-- convention, or one that has been previously recorded using a call to
-- Record_Convention_Identifier.
function Get_Convention_Name (C : Convention_Id) return Name_Id;
-- Returns the name of language convention corresponding to given