From: Samuel Tardieu <sam@rfc1149.net>
Date: Mon, 14 Apr 2008 12:11:06 +0000 (+0000)
Subject: re PR ada/16098 (Illegal program not detected, RM 13.1(6))
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=b039b10e28c986b8099ad6e013d6426387667a48;p=gcc.git

re PR ada/16098 (Illegal program not detected, RM 13.1(6))

    gcc/ada/
	PR ada/16098
	* sem_prag.adb (Error_Pragma_Ref): New.
	(Process_Convention): Specialized message for non-local
	subprogram renaming. Detect the problem in homonyms as well.

    gcc/testsuite/
	PR ada/16098
	* gnat.dg/specs/renamings.ads: New.

From-SVN: r134262
---

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9905b15ac73..cdfcdfe4f9f 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2008-04-14  Samuel Tardieu  <sam@rfc1149.net>
+
+	PR ada/16098
+	* sem_prag.adb (Error_Pragma_Ref): New.
+	(Process_Convention): Specialized message for non-local
+	subprogram renaming. Detect the problem in homonyms as well.
+
 2008-04-14  Samuel Tardieu  <sam@rfc1149.net>
 
 	PR ada/15915
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index b98e0044beb..8a9a2e91f11 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -521,6 +521,13 @@ package body Sem_Prag is
       --  reference the identifier. After placing the message, Pragma_Exit
       --  is raised.
 
+      procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id);
+      pragma No_Return (Error_Pragma_Ref);
+      --  Outputs error message for current pragma. The message may contain
+      --  a % that will be replaced with the pragma name. The parameter Ref
+      --  must be an entity whose name can be referenced by & and sloc by #.
+      --  After placing the message, Pragma_Exit is raised.
+
       function Find_Lib_Unit_Name return Entity_Id;
       --  Used for a library unit pragma to find the entity to which the
       --  library unit pragma applies, returns the entity found.
@@ -1700,6 +1707,18 @@ package body Sem_Prag is
          raise Pragma_Exit;
       end Error_Pragma_Arg_Ident;
 
+      ----------------------
+      -- Error_Pragma_Ref --
+      ----------------------
+
+      procedure Error_Pragma_Ref (Msg : String; Ref : Entity_Id) is
+      begin
+         Error_Msg_Name_1 := Pname;
+         Error_Msg_Sloc   := Sloc (Ref);
+         Error_Msg_NE (Msg, N, Ref);
+         raise Pragma_Exit;
+      end Error_Pragma_Ref;
+
       ------------------------
       -- Find_Lib_Unit_Name --
       ------------------------
@@ -2414,6 +2433,10 @@ package body Sem_Prag is
             if Nkind (Parent (Declaration_Node (E))) =
                                        N_Subprogram_Renaming_Declaration
             then
+               if Scope (E) /= Scope (Alias (E)) then
+                  Error_Pragma_Ref
+                    ("cannot apply pragma% to non-local renaming&#", E);
+               end if;
                E := Alias (E);
 
             elsif Nkind (Parent (E)) = N_Full_Type_Declaration
@@ -2547,6 +2570,12 @@ package body Sem_Prag is
                  and then Nkind (Original_Node (Parent (E1))) /=
                    N_Full_Type_Declaration
                then
+                  if Present (Alias (E1))
+                    and then Scope (E1) /= Scope (Alias (E1))
+                  then
+                     Error_Pragma_Ref
+                       ("cannot apply pragma% to non-local renaming&#", E1);
+                  end if;
                   Set_Convention_From_Pragma (E1);
 
                   if Prag_Id = Pragma_Import then
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a129d156362..5bb51e82d8c 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2008-04-14  Samuel Tardieu  <sam@rfc1149.net>
+
+	PR ada/16098
+	* gnat.dg/specs/renamings.ads: New.
+
 2008-04-14  Samuel Tardieu  <sam@rfc1149.net>
 
 	PR ada/15915
diff --git a/gcc/testsuite/gnat.dg/specs/renamings.ads b/gcc/testsuite/gnat.dg/specs/renamings.ads
new file mode 100644
index 00000000000..3b90827e9fb
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/specs/renamings.ads
@@ -0,0 +1,14 @@
+package Renamings is
+
+   package Inner is
+      procedure PI (X : Integer);
+   end Inner;
+
+   procedure P (X : Integer) renames Inner.PI;
+   procedure P (X : Float);
+   pragma Convention (C, P); -- { dg-error "non-local renaming" }
+
+   procedure Q (X : Float);
+   procedure Q (X : Integer) renames Inner.PI;
+   pragma Convention (C, Q); -- { dg-error "non-local renaming" }
+end Renamings;