Patchwork [Ada] Allow pragma Import and pragma Interface

login
register
mail settings
Submitter Arnaud Charlet
Date June 18, 2010, 8:18 a.m.
Message ID <20100618081839.GA8379@adacore.com>
Download mbox | patch
Permalink /patch/56149/
State New
Headers show

Comments

Arnaud Charlet - June 18, 2010, 8:18 a.m.
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.

Patch

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;
+
+         <<OK>> 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);