OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_cat.adb (Validate_RACW_Primitives): Do not rely on Comes_From_Source to exclude primitives from being checked.

Browse Source 
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
This commit is contained in:
Thomas Quinot 2008-03-26 08:41:04 +01:00 committed by Arnaud Charlet
parent e96db982d2
commit 2b2b679811
1 changed files with 60 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

84
gcc/ada/sem_cat.adb
View File

@ -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;