From patchwork Fri Jun 18 08:18:39 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 56149 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id C4C801007D4 for ; Fri, 18 Jun 2010 18:18:54 +1000 (EST) Received: (qmail 4544 invoked by alias); 18 Jun 2010 08:18:45 -0000 Received: (qmail 4159 invoked by uid 22791); 18 Jun 2010 08:18:37 -0000 X-SWARE-Spam-Status: No, hits=-0.9 required=5.0 tests=AWL, BAYES_20, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 18 Jun 2010 08:18:22 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 18001CB0253; Fri, 18 Jun 2010 10:18:29 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id D3YqyXuLwHMM; Fri, 18 Jun 2010 10:18:29 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 0457FCB01E2; Fri, 18 Jun 2010 10:18:29 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 28431D9B31; Fri, 18 Jun 2010 10:18:39 +0200 (CEST) Date: Fri, 18 Jun 2010 10:18:39 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Allow pragma Import and pragma Interface Message-ID: <20100618081839.GA8379@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org GNAT previously treated Interface identically to Import, and in particular enforced the rule of no duplication, so it was illegal to have an Import and Interface for the same entity, but this combination is useful for maintaining Ada 83/Ada 95 compatibility and is allowed by Rational. This patch implements this relaxation of the rules, as shown by the following test: 1. package import_interface is 2. procedure q1; 3. pragma Import (C, q1); 4. pragma Interface (C, q1); -- OK 5. 6. procedure q2; 7. pragma Interface (C, q2); 8. pragma Import (C, q2); -- OK 9. 10. procedure q3; 11. pragma Import (C, q3); 12. pragma Interface (Ada, q3); -- ERR: bad convention | >>> convention differs from that given at at line 11 13. 14. procedure q4; 15. pragma Interface (C, q4); 16. pragma Import (Ada, q4); -- ERR: bad convention | >>> convention differs from that given at at line 15 17. 18. procedure q5; 19. pragma Interface (C, q5); 20. pragma Export (C, q5); -- ERR: multiple pragmas | >>> at most one Convention/Export/Import pragma is allowed 21. 22. procedure q6; 23. pragma Export (C, q6); 24. pragma Interface (C, q6); -- ERR: Multiple pragmas | >>> at most one Convention/Export/Import pragma is allowed 25. end; Tested on x86_64-pc-linux-gnu, committed on trunk 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. Index: gnat_rm.texi =================================================================== --- gnat_rm.texi (revision 160959) +++ gnat_rm.texi (working copy) @@ -2856,7 +2856,12 @@ the standard Ada pragma @code{Import}. 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 Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 160959) +++ sem_prag.adb (working copy) @@ -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; ------------------------- Index: sinfo.adb =================================================================== --- sinfo.adb (revision 160959) +++ sinfo.adb (working copy) @@ -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 Index: sinfo.ads =================================================================== --- sinfo.ads (revision 160959) +++ sinfo.ads (working copy) @@ -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);