Commit 5320014a by Samuel Tardieu Committed by Samuel Tardieu

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

    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
parent 28d08315
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> 2007-12-07 Ludovic Brenta <ludovic@ludovic-brenta.org>
PR ada/34361 PR ada/34361
...@@ -3786,7 +3786,9 @@ package Einfo is ...@@ -3786,7 +3786,9 @@ package Einfo is
E_Anonymous_Access_Subprogram_Type, E_Anonymous_Access_Subprogram_Type,
-- An anonymous access to subprogram type, created by an access to -- 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, E_Access_Protected_Subprogram_Type,
-- An access to a protected subprogram, created by the corresponding -- An access to a protected subprogram, created by the corresponding
......
...@@ -15983,12 +15983,15 @@ package body Sem_Ch3 is ...@@ -15983,12 +15983,15 @@ package body Sem_Ch3 is
-- This is done only once, and only if there is no previous partial -- This is done only once, and only if there is no previous partial
-- view of the type. -- 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; function Mentions_T (Acc_Def : Node_Id) return Boolean;
-- Check whether an access definition includes a reference to -- Check whether an access definition includes a reference to
-- the enclosing record type. The reference can be a subtype -- the enclosing record type. The reference can be a subtype mark
-- mark in the access definition itself, or a 'Class attribute -- in the access definition itself, a 'Class attribute reference, or
-- reference, or recursively a reference appearing in a parameter -- recursively a reference appearing in a parameter specification
-- type in an access_to_subprogram definition. -- or result definition of an access_to_subprogram definition.
-------------------------------------- --------------------------------------
-- Build_Incomplete_Type_Declaration -- -- Build_Incomplete_Type_Declaration --
...@@ -16071,12 +16074,12 @@ package body Sem_Ch3 is ...@@ -16071,12 +16074,12 @@ package body Sem_Ch3 is
end if; end if;
end Build_Incomplete_Type_Declaration; 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); Type_Id : constant Name_Id := Chars (Typ);
function Names_T (Nam : Node_Id) return Boolean; function Names_T (Nam : Node_Id) return Boolean;
...@@ -16113,75 +16116,94 @@ package body Sem_Ch3 is ...@@ -16113,75 +16116,94 @@ package body Sem_Ch3 is
end if; end if;
end Names_T; end Names_T;
-- Start of processing for Mentions_T -- Start of processing for Designates_T
begin begin
if No (Access_To_Subprogram_Definition (Acc_Def)) then if Nkind (Subt) = N_Identifier then
Subt := Subtype_Mark (Acc_Def); 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 -- Reference can be through an expanded name which has not been
-- analyzed yet, and which designates enclosing scopes. -- analyzed yet, and which designates enclosing scopes.
elsif Nkind (Subt) = N_Selected_Component then elsif Nkind (Subt) = N_Selected_Component then
if Names_T (Subt) then if Names_T (Subt) then
return True; 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.
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 -- Otherwise it must denote an entity that is already visible.
-- a 'Class attribute. -- The access definition may name a subtype of the enclosing
-- type, if there is a previous incomplete declaration for it.
elsif Nkind (Subt) = N_Attribute_Reference
and then Attribute_Name (Subt) = Name_Class
then
return Names_T (Prefix (Subt));
else 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; 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 else
-- Component is an access_to_subprogram: examine its formals return False;
end if;
end Designates_T;
declare ----------------
Param_Spec : Node_Id; -- Mentions_T --
----------------
begin function Mentions_T (Acc_Def : Node_Id) return Boolean is
Param_Spec := Param_Spec : Node_Id;
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); Acc_Subprg : constant Node_Id :=
end loop; Access_To_Subprogram_Definition (Acc_Def);
return False; begin
end; if No (Acc_Subprg) then
return Designates_T (Subtype_Mark (Acc_Def));
end if; 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; end Mentions_T;
-- Start of processing for Check_Anonymous_Access_Components -- Start of processing for Check_Anonymous_Access_Components
...@@ -16279,7 +16301,13 @@ package body Sem_Ch3 is ...@@ -16279,7 +16301,13 @@ package body Sem_Ch3 is
Make_Component_Definition (Loc, Make_Component_Definition (Loc,
Subtype_Indication => Subtype_Indication =>
New_Occurrence_Of (Anon_Access, Loc))); 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); Set_Is_Local_Anonymous_Access (Anon_Access);
end if; end if;
......
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> 2007-12-09 Paul Thomas <pault@gcc.gnu.org>
PR fortran/32129 PR fortran/32129
-- { 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;
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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment