Patchwork [Ada] Improve detection of bad Stdcall convention

login
register
mail settings
Submitter Arnaud Charlet
Date April 24, 2013, 1:13 p.m.
Message ID <20130424131331.GA14829@adacore.com>
Download mbox | patch
Permalink /patch/239203/
State New
Headers show

Comments

Arnaud Charlet - April 24, 2013, 1:13 p.m.
This patch corrects a failure to issue a message when a Convention
pragma specifying Stdcall applied to a set of homonyms, and other
than the last was a dispatching pragma. The following program
compiles with the indicated warnings:

     1. package SCDispatch is
     2.    type T1 is tagged null record;
     3.    type T2 is tagged null record;
     4.    type T3 is tagged null record;
     5.    procedure Call (Ob : T1);
     6.    pragma Convention (Stdcall, Call);
                              |
        >>> dispatching subprogram at line 5 cannot use
            Stdcall convention

     7.    procedure Call (Ob : T2);
     8.    procedure Call (Ob : T3);
     9.    procedure Call (V1, V2 : Integer);
    10.    pragma Convention (Stdcall, Call);
                              |
        >>> dispatching subprogram at line 8 cannot use
            Stdcall convention
        >>> dispatching subprogram at line 7 cannot use
            Stdcall convention

    11. end SCDispatch;

Tested on x86_64-pc-linux-gnu, committed on trunk

2013-04-24  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb (Process_Convention): Move Stdcall tests to
	Set_Convention_From_Pragma so that they are applied to each
	entry of a homonym set.
	(Process_Convention): Don't try to set convention if already set.

Patch

Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 198224)
+++ sem_prag.adb	(working copy)
@@ -4928,6 +4928,51 @@ 
                   & "operation", Arg1);
             end if;
 
+            --  Special checks for Convention_Stdcall
+
+            if C = Convention_Stdcall then
+
+               --  A dispatching call is not allowed. A dispatching subprogram
+               --  cannot be used to interface to the Win32 API, so in fact
+               --  this check does not impose any effective restriction.
+
+               if Is_Dispatching_Operation (E) then
+                  Error_Msg_Sloc := Sloc (E);
+
+                  --  Note: make this unconditional so that if there is more
+                  --  than one call to which the pragma applies, we get a
+                  --  message for each call. Also don't use Error_Pragma,
+                  --  so that we get multiple messages!
+
+                  Error_Msg_N
+                    ("dispatching subprogram# cannot use Stdcall convention!",
+                     Arg1);
+
+               --  Subprogram is allowed, but not a generic subprogram
+
+               elsif not Is_Subprogram (E)
+                 and then not Is_Generic_Subprogram (E)
+
+                 --  A variable is OK
+
+                 and then Ekind (E) /= E_Variable
+
+                 --  An access to subprogram is also allowed
+
+                 and then not
+                   (Is_Access_Type (E)
+                     and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+
+                 --  Allow internal call to set convention of subprogram type
+
+                 and then not (Ekind (E) = E_Subprogram_Type)
+               then
+                  Error_Pragma_Arg
+                    ("second argument of pragma% must be subprogram (type)",
+                     Arg2);
+               end if;
+            end if;
+
             --  Set the convention
 
             Set_Convention (E, C);
@@ -5158,41 +5203,8 @@ 
               ("second argument of pragma% must be a subprogram", Arg2);
          end if;
 
-         --  Stdcall case
+         --  Deal with non-subprogram cases
 
-         if C = Convention_Stdcall then
-
-            --  A dispatching call is not allowed. A dispatching subprogram
-            --  cannot be used to interface to the Win32 API, so in fact this
-            --  check does not impose any effective restriction.
-
-            if Is_Dispatching_Operation (E) then
-
-               Error_Pragma
-                 ("dispatching subprograms cannot use Stdcall convention");
-
-            --  Subprogram is allowed, but not a generic subprogram, and not a
-            --  dispatching operation.
-
-            elsif not Is_Subprogram (E)
-              and then not Is_Generic_Subprogram (E)
-
-              --  A variable is OK
-
-              and then Ekind (E) /= E_Variable
-
-              --  An access to subprogram is also allowed
-
-              and then not
-                (Is_Access_Type (E)
-                  and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-            then
-               Error_Pragma_Arg
-                 ("second argument of pragma% must be subprogram (type)",
-                  Arg2);
-            end if;
-         end if;
-
          if not Is_Subprogram (E)
            and then not Is_Generic_Subprogram (E)
          then
@@ -5202,7 +5214,7 @@ 
                Check_First_Subtype (Arg2);
                Set_Convention_From_Pragma (Base_Type (E));
 
-               --  For subprograms, we must set the convention on the
+               --  For access subprograms, we must set the convention on the
                --  internally generated directly designated type as well.
 
                if Ekind (E) = E_Access_Subprogram_Type then
@@ -5251,6 +5263,12 @@ 
                E1 := Homonym (E1);
                exit when No (E1) or else Scope (E1) /= Current_Scope;
 
+               --  Ignore entry for which convention is already set
+
+               if Has_Convention_Pragma (E1) then
+                  goto Continue;
+               end if;
+
                --  Do not set the pragma on inherited operations or on formal
                --  subprograms.
 
@@ -5274,6 +5292,9 @@ 
                      Generate_Reference (E1, Id, 'b');
                   end if;
                end if;
+
+            <<Continue>>
+               null;
             end loop;
          end if;
       end Process_Convention;