+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
-- --
-- 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- --
-- --
-- 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- --
-- 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)
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
-- --
-- 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- --
-- 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
-- --
-- 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- --
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 --
--------------------------------
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
-- 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;
Set_Is_Statically_Allocated (E);
end if;
end if;
+
+ <<OK>> null;
end Set_Imported;
-------------------------
-- --
-- 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- --
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;
-----------------------------
Comp := Next_Entity (Comp);
end loop;
-
end if;
Get_Next_Interp (I, It);
-- 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;
-------------------
-- --
-- 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- --
-- 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,
-- --
-- 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- --
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
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
-- --
-- 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- --
-- '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
-- 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
-- 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
-- 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;
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
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
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);
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);
-- --
-- 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- --
-- 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
projects / thirdparty / gcc.git / commitdiff
