From 2b2b6798119883d6cc535db15cc19baaae32bb49 Mon Sep 17 00:00:00 2001
From: Thomas Quinot <quinot@adacore.com>
Date: Wed, 26 Mar 2008 08:41:04 +0100
Subject: [PATCH] sem_cat.adb (Validate_RACW_Primitives): Do not rely on
 Comes_From_Source to exclude primitives from being checked.

2008-03-26  Thomas Quinot  <quinot@adacore.com>

	* sem_cat.adb (Validate_RACW_Primitives): Do not rely on
	Comes_From_Source to exclude primitives from being checked. We want to
	exclude predefined primitives only, so use the appropriate specific
	predicate. Also, flag a formal parameter of an anonymous
	access-to-subprogram type as illegal for a primitive operation of a
	remote access to class-wide type.

From-SVN: r133572
---
 gcc/ada/sem_cat.adb | 84 ++++++++++++++++++++++++++++++++-------------
 1 file changed, 60 insertions(+), 24 deletions(-)

diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 9bcd622a426..b9dbfb18f94 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2008, 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- --
@@ -28,6 +28,7 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Exp_Util; use Exp_Util;
 with Fname;    use Fname;
 with Lib;      use Lib;
 with Namet;    use Namet;
@@ -214,11 +215,26 @@ package body Sem_Cat is
          --  Here we have an error
 
          else
-            if Is_Subunit then
+            --  Don't give error if main unit is not an internal unit, and the
+            --  unit generating the message is an internal unit. This is the
+            --  situation in which such messages would be ignored in any case,
+            --  so it is convenient not to generate them (since it causes
+            --  annoying inteference with debugging)
+
+            if Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
+              and then not Is_Internal_File_Name (Unit_File_Name (Main_Unit))
+            then
+               return;
+
+            --  Subunit case
+
+            elsif Is_Subunit then
                Error_Msg_NE
                  ("<subunit cannot depend on& " &
                   "(parent has wrong categorization)", N, Depended_Entity);
 
+            --  Normal unit, not subunit
+
             else
                Error_Msg_NE
                  ("<cannot depend on& " &
@@ -660,8 +676,7 @@ package body Sem_Cat is
             --  previous analysis.
 
             if Nkind (PN) = N_Pragma then
-
-               case Get_Pragma_Id (Chars (PN)) is
+               case Get_Pragma_Id (PN) is
                   when Pragma_All_Calls_Remote   |
                     Pragma_Preelaborate          |
                     Pragma_Pure                  |
@@ -1297,12 +1312,36 @@ package body Sem_Cat is
       Primitive_Subprograms  : Elist_Id;
       Subprogram_Elmt        : Elmt_Id;
       Subprogram             : Entity_Id;
-      Profile                : List_Id;
       Param_Spec             : Node_Id;
       Param                  : Entity_Id;
       Param_Type             : Entity_Id;
       Rtyp                   : Node_Id;
 
+      procedure Illegal_RACW (Msg : String; N : Node_Id);
+      --  Diagnose that T is illegal because of the given reason, associated
+      --  with the location of node N.
+
+      Illegal_RACW_Message_Issued : Boolean := False;
+      --  Set True once Illegal_RACW has been called
+
+      ------------------
+      -- Illegal_RACW --
+      ------------------
+
+      procedure Illegal_RACW (Msg : String; N : Node_Id) is
+      begin
+         if not Illegal_RACW_Message_Issued then
+            Error_Msg_N
+              ("illegal remote access to class-wide type&", T);
+            Illegal_RACW_Message_Issued := True;
+         end if;
+
+         Error_Msg_Sloc := Sloc (N);
+         Error_Msg_N ("\\" & Msg & " in primitive#", T);
+      end Illegal_RACW;
+
+   --  Start of processing for Validate_RACW_Primitives
+
    begin
       Desig_Type := Etype (Designated_Type (T));
 
@@ -1312,7 +1351,9 @@ package body Sem_Cat is
       while Subprogram_Elmt /= No_Elmt loop
          Subprogram := Node (Subprogram_Elmt);
 
-         if not Comes_From_Source (Subprogram) then
+         if Is_Predefined_Dispatching_Operation (Subprogram)
+           or else Is_Hidden (Subprogram)
+         then
             goto Next_Subprogram;
          end if;
 
@@ -1325,15 +1366,14 @@ package body Sem_Cat is
                null;
 
             elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
-               Error_Msg_N
-                 ("anonymous access result in remote object primitive", Rtyp);
+               Illegal_RACW ("anonymous access result", Rtyp);
 
             elsif Is_Limited_Type (Rtyp) then
                if No (TSS (Rtyp, TSS_Stream_Read))
                     or else
                   No (TSS (Rtyp, TSS_Stream_Write))
                then
-                  Error_Msg_N
+                  Illegal_RACW
                     ("limited return type must have Read and Write attributes",
                      Parent (Subprogram));
                   Explain_Limited_Type (Rtyp, Parent (Subprogram));
@@ -1342,16 +1382,12 @@ package body Sem_Cat is
             end if;
          end if;
 
-         Profile := Parameter_Specifications (Parent (Subprogram));
-
-         --  Profile must exist, otherwise not primitive operation
-
-         Param_Spec := First (Profile);
-         while Present (Param_Spec) loop
+         Param := First_Formal (Subprogram);
+         while Present (Param) loop
 
             --  Now find out if this parameter is a controlling parameter
 
-            Param      := Defining_Identifier (Param_Spec);
+            Param_Spec := Parent (Param);
             Param_Type := Etype (Param);
 
             if Is_Controlling_Formal (Param) then
@@ -1361,13 +1397,13 @@ package body Sem_Cat is
 
                null;
 
-            elsif Ekind (Param_Type) = E_Anonymous_Access_Type then
-
+            elsif Ekind (Param_Type) = E_Anonymous_Access_Type
+              or else Ekind (Param_Type) = E_Anonymous_Access_Subprogram_Type
+            then
                --  From RM E.2.2(14), no access parameter other than
                --  controlling ones may be used.
 
-               Error_Msg_N
-                 ("non-controlling access parameter", Param_Spec);
+               Illegal_RACW ("non-controlling access parameter", Param_Spec);
 
             elsif Is_Limited_Type (Param_Type) then
 
@@ -1378,7 +1414,7 @@ package body Sem_Cat is
                     or else
                   No (TSS (Param_Type, TSS_Stream_Write))
                then
-                  Error_Msg_N
+                  Illegal_RACW
                     ("limited formal must have Read and Write attributes",
                      Param_Spec);
                   Explain_Limited_Type (Param_Type, Param_Spec);
@@ -1387,7 +1423,7 @@ package body Sem_Cat is
 
             --  Check next parameter in this subprogram
 
-            Next (Param_Spec);
+            Next_Formal (Param);
          end loop;
 
          <<Next_Subprogram>>
@@ -1654,7 +1690,7 @@ package body Sem_Cat is
          Error_Msg_N
            ("error in designated type of remote access to class-wide type", T);
          Error_Msg_N
-           ("\must be tagged limited private or private extension of type", T);
+           ("\must be tagged limited private or private extension", T);
          return;
       end if;
 
@@ -1788,7 +1824,7 @@ package body Sem_Cat is
             return;
          end if;
 
-         Error_Msg_N ("incorrect remote type dereference", N);
+         Error_Msg_N ("incorrect dereference of remote type", N);
       end if;
    end Validate_Remote_Access_To_Class_Wide_Type;
 
-- 
2.30.2