===================================================================
@@ -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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
-------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- 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);
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 <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.