From c28408b78417c388b52a53720ae2fd512514881f Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Fri, 18 Jun 2010 08:17:48 +0000 Subject: [PATCH] sem_res.adb (Analyze_Indexed_Component, [...]): Warn on assigning to packed atomic component. 2010-06-18 Robert Dewar * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): Warn on assigning to packed atomic component. 2010-06-18 Robert Dewar * 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 * 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 * lib-xref.adb (Generate_Reference): Fix bad reference to Has_Pragma_Unreferenced (clients should always use Has_Unreferenced). From-SVN: r160961 --- gcc/ada/ChangeLog | 25 ++++++ gcc/ada/einfo.adb | 2 +- gcc/ada/einfo.ads | 4 +- gcc/ada/gnat_rm.texi | 7 +- gcc/ada/lib-xref.adb | 4 +- gcc/ada/sem_prag.adb | 182 +++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_res.adb | 38 ++++++++- gcc/ada/sem_util.ads | 4 +- gcc/ada/sinfo.adb | 18 +++- gcc/ada/sinfo.ads | 26 +++++- gcc/ada/snames.ads-tmpl | 9 +- 11 files changed, 299 insertions(+), 20 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fde2d2588c62..5075e1b12f62 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2010-06-18 Robert Dewar + + * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): + Warn on assigning to packed atomic component. + +2010-06-18 Robert Dewar + + * 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 + + * 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 + + * lib-xref.adb (Generate_Reference): Fix bad reference to + Has_Pragma_Unreferenced (clients should always use Has_Unreferenced). + 2010-06-17 Eric Botcazou * gcc-interface/trans.c (set_gnu_expr_location_from_node): New static diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 5a6e8dd5bc24..005823145cbb 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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- -- diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 12a770fb956e..6c4dde715919 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index def4db1ac9a7..0cbe160af7bd 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 516fc55261fd..987d178e1c9e 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 29c706721da6..bcc416b1a3a0 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; + + <> null; end Set_Imported; ------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index aa551ac27678..7ae5fab45a55 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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; ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 9e7435788293..806cbcf8c874 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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, diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 8a9d25308554..382968ca81ce 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f6754a8aae78..705530c75688 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 89bbe4c7e408..546e83c79160 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -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 -- 2.47.2