FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR ada/34366 (Legal program rejected, various anonymous access-to-subprogram types, Ada 2005)

Browse source 
gcc/ada/
	PR ada/34366
	* sem_ch3.adb (Designates_T): New function.
	(Mentions_T): Factor reusable part of the logic into Designates_T.
	Consider non-access parameters and access and non-access result.
	(Check_Anonymous_Access_Components): Set ekind of anonymous access to
	E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type.

	* einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type.

    gcc/testsuite/
	PR ada/34366
	* gnat.dg/enclosing_record_reference.ads,
	gnat.dg/enclosing_record_reference.adb: New test.

From-SVN: r130720
This commit is contained in:
Samuel Tardieu 2007-12-09 11:07:54 +00:00 • committed by Samuel Tardieu
parent 28d08315ed
commit 5320014a06
6 changed files with 153 additions and 67 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
gcc/ada/ChangeLog
View file

@ -1,3 +1,14 @@
2007-12-09 Samuel Tardieu <sam@rfc1149.net>
PR ada/34366
* sem_ch3.adb (Designates_T): New function.
(Mentions_T): Factor reusable part of the logic into Designates_T.
Consider non-access parameters and access and non-access result.
(Check_Anonymous_Access_Components): Set ekind of anonymous access to
E_Subprogram_Type to E_Anonymous_Access_Subprogram_Type.
* einfo.ads: Update comment for E_Anonymous_Access_Subprogram_Type.
2007-12-07 Ludovic Brenta <ludovic@ludovic-brenta.org>
PR ada/34361

4
gcc/ada/einfo.ads
View file

@ -3786,7 +3786,9 @@ package Einfo is
E_Anonymous_Access_Subprogram_Type,
-- An anonymous access to subprogram type, created by an access to
-- subprogram declaration.
-- subprogram declaration, or generated for a current instance of
-- a type name appearing within a component definition that has an
-- anonymous access to subprogram type.
E_Access_Protected_Subprogram_Type,
-- An access to a protected subprogram, created by the corresponding

160
gcc/ada/sem_ch3.adb
View file

@ -15983,12 +15983,15 @@ package body Sem_Ch3 is
-- This is done only once, and only if there is no previous partial
-- view of the type.
function Designates_T (Subt : Node_Id) return Boolean;
-- Check whether a node designates the enclosing record type
function Mentions_T (Acc_Def : Node_Id) return Boolean;
-- Check whether an access definition includes a reference to
-- the enclosing record type. The reference can be a subtype
-- mark in the access definition itself, or a 'Class attribute
-- reference, or recursively a reference appearing in a parameter
-- type in an access_to_subprogram definition.
-- the enclosing record type. The reference can be a subtype mark
-- in the access definition itself, a 'Class attribute reference, or
-- recursively a reference appearing in a parameter specification
-- or result definition of an access_to_subprogram definition.
--------------------------------------
-- Build_Incomplete_Type_Declaration --
@ -16071,12 +16074,12 @@ package body Sem_Ch3 is
end if;
end Build_Incomplete_Type_Declaration;
----------------
-- Mentions_T --
----------------
------------------
-- Designates_T --
------------------
function Designates_T (Subt : Node_Id) return Boolean is
function Mentions_T (Acc_Def : Node_Id) return Boolean is
Subt : Node_Id;
Type_Id : constant Name_Id := Chars (Typ);
function Names_T (Nam : Node_Id) return Boolean;
@ -16113,75 +16116,94 @@ package body Sem_Ch3 is
end if;
end Names_T;
-- Start of processing for Mentions_T
-- Start of processing for Designates_T
begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then
Subt := Subtype_Mark (Acc_Def);
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Type_Id;
if Nkind (Subt) = N_Identifier then
return Chars (Subt) = Type_Id;
-- Reference can be through an expanded name which has not been
-- analyzed yet, and which designates enclosing scopes.
elsif Nkind (Subt) = N_Selected_Component then
if Names_T (Subt) then
return True;
elsif Nkind (Subt) = N_Selected_Component then
if Names_T (Subt) then
return True;
-- Otherwise it must denote an entity that is already visible.
-- The access definition may name a subtype of the enclosing
-- type, if there is a previous incomplete declaration for it.
-- Otherwise it must denote an entity that is already visible.
-- The access definition may name a subtype of the enclosing
-- type, if there is a previous incomplete declaration for it.
else
Find_Selected_Component (Subt);
return
Is_Entity_Name (Subt)
and then Scope (Entity (Subt)) = Current_Scope
and then (Chars (Base_Type (Entity (Subt))) = Type_Id
or else
(Is_Class_Wide_Type (Entity (Subt))
and then
Chars (Etype (Base_Type (Entity (Subt))))
= Type_Id));
end if;
-- A reference to the current type may appear as the prefix of
-- a 'Class attribute.
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
then
return Names_T (Prefix (Subt));
else
return False;
Find_Selected_Component (Subt);
return
Is_Entity_Name (Subt)
and then Scope (Entity (Subt)) = Current_Scope
and then
(Chars (Base_Type (Entity (Subt))) = Type_Id
or else
(Is_Class_Wide_Type (Entity (Subt))
and then
Chars (Etype (Base_Type (Entity (Subt))))
= Type_Id));
end if;
-- A reference to the current type may appear as the prefix of
-- a 'Class attribute.
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
then
return Names_T (Prefix (Subt));
else
-- Component is an access_to_subprogram: examine its formals
declare
Param_Spec : Node_Id;
begin
Param_Spec :=
First
(Parameter_Specifications
(Access_To_Subprogram_Definition (Acc_Def)));
while Present (Param_Spec) loop
if Nkind (Parameter_Type (Param_Spec))
= N_Access_Definition
and then Mentions_T (Parameter_Type (Param_Spec))
then
return True;
end if;
Next (Param_Spec);
end loop;
return False;
end;
return False;
end if;
end Designates_T;
----------------
-- Mentions_T --
----------------
function Mentions_T (Acc_Def : Node_Id) return Boolean is
Param_Spec : Node_Id;
Acc_Subprg : constant Node_Id :=
Access_To_Subprogram_Definition (Acc_Def);
begin
if No (Acc_Subprg) then
return Designates_T (Subtype_Mark (Acc_Def));
end if;
-- Component is an access_to_subprogram: examine its formals,
-- and result definition in the case of an access_to_function.
Param_Spec := First (Parameter_Specifications (Acc_Subprg));
while Present (Param_Spec) loop
if Nkind (Parameter_Type (Param_Spec)) = N_Access_Definition
and then Mentions_T (Parameter_Type (Param_Spec))
then
return True;
elsif Designates_T (Parameter_Type (Param_Spec)) then
return True;
end if;
Next (Param_Spec);
end loop;
if Nkind (Acc_Subprg) = N_Access_Function_Definition then
if Nkind (Result_Definition (Acc_Subprg)) =
N_Access_Definition
then
return Mentions_T (Result_Definition (Acc_Subprg));
else
return Designates_T (Result_Definition (Acc_Subprg));
end if;
end if;
return False;
end Mentions_T;
-- Start of processing for Check_Anonymous_Access_Components
@ -16279,7 +16301,13 @@ package body Sem_Ch3 is
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Anon_Access, Loc)));
Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
if Ekind (Designated_Type (Anon_Access)) = E_Subprogram_Type then
Set_Ekind (Anon_Access, E_Anonymous_Access_Subprogram_Type);
else
Set_Ekind (Anon_Access, E_Anonymous_Access_Type);
end if;
Set_Is_Local_Anonymous_Access (Anon_Access);
end if;

6
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,9 @@
2007-12-09 Samuel Tardieu <sam@rfc1149.net>
PR ada/34366
* gnat.dg/enclosing_record_reference.ads,
gnat.dg/enclosing_record_reference.adb: New test.
2007-12-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/32129

24
gcc/testsuite/gnat.dg/enclosing_record_reference.adb Normal file
View file

@ -0,0 +1,24 @@
-- { dg-do compile }
package body Enclosing_Record_Reference is
R: aliased T;
function F1 (x: integer) return T is begin return R; end;
function F2 (x: T) return integer is begin return 0; end;
function F3 (x: T) return T is begin return R; end;
function F4 (x: integer) return access T is begin return R'access; end;
function F5 (x: access T) return integer is begin return 0; end;
function F6 (x: access T) return access T is begin return R'access; end;
function F7 (x: T) return access T is begin return R'access; end;
function F8 (x: access T) return T is begin return R; end;
begin
R.F1 := F1'Access;
R.F2 := F2'Access;
R.F3 := F3'Access;
R.F4 := F4'Access;
R.F5 := F5'Access;
R.F6 := F6'Access;
R.F7 := F7'Access;
R.F8 := F8'Access;
end Enclosing_Record_Reference;

15
gcc/testsuite/gnat.dg/enclosing_record_reference.ads Normal file
View file

@ -0,0 +1,15 @@
package Enclosing_Record_Reference is
pragma elaborate_body;
type T is record
F1: access function(x: integer) return T;
F2: access function(x: T) return integer; --??
F3: access function(x: T) return T; --??
F4: access function(x: integer) return access T; --??
F5: access function(x: access T) return integer;
F6: access function(x: access T) return access T;
F7: access function(x: T) return access T; --??
F8: access function(x: access T) return T;
end record;
end Enclosing_Record_Reference;