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

sem_ch6.ads, [...] (Check_Conformance): In case of anonymous access types the null-exclusion and access-to-constant... 

2005-09-01  Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_ch6.ads, sem_ch6.adb (Check_Conformance): In case of anonymous
	access types the null-exclusion and access-to-constant attributes must
	also match.
	(Analyze_Return_Statement): When the result type is an anonymous access
	type, apply a conversion of the return expression to the access type
	to ensure that appropriate accessibility checks are performed.
	(Analyze_Return_Type): For the case of an anonymous access result type,
	generate the Itype and set Is_Local_Anonymous_Access on the type.
	Add ??? placeholder for check to disallow returning a limited object
	in Ada 2005 unless it's an aggregate or a result of a function call.
	Change calls from Subtype_Mark to Result_Definition.
	(Analyze_Subprogram_Body): Change formal Subtype_Mark to
	Result_Definition in call to Make_Function_Specification.
	(Build_Body_To_Inline): Change Set_Subtype_Mark to
	Set_Result_Definition.
	(Make_Inequality_Operator): Change formal Subtype_Mark to
	Result_Definition in call to Make_Function_Specification.
	(Process_Formals): Create the new null-excluding itype if required.
	(New_Overloaded_Entity): For an entity overriding an interface primitive
	check if the entity also covers other abstract subprograms in the same
	scope. This is required to handle the general case, that is, overriding
	other interface primitives and overriding abstract subprograms inherited
	from some abstract ancestor type.
	(New_Overloaded_Entity): For an overriding entity that comes from
	source, note the operation that it overrides.
	(Check_Conformance, Type_Conformant): Addition of one new formal
	to skip controlling formals in the analysis. This is used to
	handle overloading of abstract interfaces.
	(Base_Types_Match): Add missing case for types imported from
	limited-with clauses
	(New_Overloaded_Entity): Add barrier to protect the use of
	the "alias" attribute.

From-SVN: r103883
This commit is contained in:
Javier Miranda 2005-09-05 10:02:21 +02:00 committed by Arnaud Charlet
parent ec6078e39b
commit 41251c605f
2 changed files with 210 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

308
gcc/ada/sem_ch6.adb
View File

@ -34,6 +34,7 @@ with Expander; use Expander;
with Exp_Ch7; use Exp_Ch7; with Exp_Ch7; use Exp_Ch7;
with Fname; use Fname; with Fname; use Fname;
with Freeze; use Freeze; with Freeze; use Freeze;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
with Namet; use Namet; with Namet; use Namet;
with Lib; use Lib; with Lib; use Lib;
@ -103,13 +104,14 @@ package body Sem_Ch6 is
-- RM definitions of the corresponding terms. -- RM definitions of the corresponding terms.
procedure Check_Conformance procedure Check_Conformance
(New_Id : Entity_Id; (New_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
Ctype : Conformance_Type; Ctype : Conformance_Type;
Errmsg : Boolean; Errmsg : Boolean;
Conforms : out Boolean; Conforms : out Boolean;
Err_Loc : Node_Id := Empty; Err_Loc : Node_Id := Empty;
Get_Inst : Boolean := False); Get_Inst : Boolean := False;
Skip_Controlling_Formals : Boolean := False);
-- Given two entities, this procedure checks that the profiles associated -- Given two entities, this procedure checks that the profiles associated
-- with these entities meet the conformance criterion given by the third -- with these entities meet the conformance criterion given by the third
-- parameter. If they conform, Conforms is set True and control returns -- parameter. If they conform, Conforms is set True and control returns
@ -733,6 +735,18 @@ package body Sem_Ch6 is
Set_Return_Type (N, R_Type); Set_Return_Type (N, R_Type);
Analyze_And_Resolve (Expr, R_Type); Analyze_And_Resolve (Expr, R_Type);
-- Ada 2005 (AI-318-02): When the result type is an anonymous
-- access type, apply an implicit conversion of the expression
-- to that type to force appropriate static and run-time
-- accessibility checks.
if Ada_Version >= Ada_05
and then Ekind (R_Type) = E_Anonymous_Access_Type
then
Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
Analyze_And_Resolve (Expr, R_Type);
end if;
if (Is_Class_Wide_Type (Etype (Expr)) if (Is_Class_Wide_Type (Etype (Expr))
or else Is_Dynamically_Tagged (Expr)) or else Is_Dynamically_Tagged (Expr))
and then not Is_Class_Wide_Type (R_Type) and then not Is_Class_Wide_Type (R_Type)
@ -743,6 +757,22 @@ package body Sem_Ch6 is
Apply_Constraint_Check (Expr, R_Type); Apply_Constraint_Check (Expr, R_Type);
-- Ada 2005 (AI-318-02): Return-by-reference types have been
-- removed and replaced by anonymous access results. This is
-- an incompatibility with Ada 95. Not clear whether this
-- should be enforced yet or perhaps controllable with a
-- special switch. ???
-- if Ada_Version >= Ada_05
-- and then Is_Limited_Type (R_Type)
-- and then Nkind (Expr) /= N_Aggregate
-- and then Nkind (Expr) /= N_Extension_Aggregate
-- and then Nkind (Expr) /= N_Function_Call
-- then
-- Error_Msg_N
-- ("(Ada 2005) illegal operand for limited return", N);
-- end if;
-- ??? A real run-time accessibility check is needed in cases -- ??? A real run-time accessibility check is needed in cases
-- involving dereferences of access parameters. For now we just -- involving dereferences of access parameters. For now we just
-- check the static cases. -- check the static cases.
@ -798,18 +828,37 @@ package body Sem_Ch6 is
Typ : Entity_Id := Empty; Typ : Entity_Id := Empty;
begin begin
if Subtype_Mark (N) /= Error then if Result_Definition (N) /= Error then
Find_Type (Subtype_Mark (N)); if Nkind (Result_Definition (N)) = N_Access_Definition then
Typ := Entity (Subtype_Mark (N)); Typ := Access_Definition (N, Result_Definition (N));
Set_Etype (Designator, Typ); Set_Parent (Typ, Result_Definition (N));
Set_Is_Local_Anonymous_Access (Typ);
Set_Etype (Designator, Typ);
if Ekind (Typ) = E_Incomplete_Type -- Ada 2005 (AI-231): Static checks
or else (Is_Class_Wide_Type (Typ)
and then -- Null_Exclusion_Static_Checks needs to be extended to handle
Ekind (Root_Type (Typ)) = E_Incomplete_Type) -- null exclusion checks for function specifications. ???
then
Error_Msg_N -- if Null_Exclusion_Present (N) then
("invalid use of incomplete type", Subtype_Mark (N)); -- Null_Exclusion_Static_Checks (Param_Spec);
-- end if;
-- Subtype_Mark case
else
Find_Type (Result_Definition (N));
Typ := Entity (Result_Definition (N));
Set_Etype (Designator, Typ);
if Ekind (Typ) = E_Incomplete_Type
or else (Is_Class_Wide_Type (Typ)
and then
Ekind (Root_Type (Typ)) = E_Incomplete_Type)
then
Error_Msg_N
("invalid use of incomplete type", Result_Definition (N));
end if;
end if; end if;
else else
@ -1083,7 +1132,8 @@ package body Sem_Ch6 is
Make_Defining_Identifier (Sloc (Body_Id), Make_Defining_Identifier (Sloc (Body_Id),
Chars => Chars (Body_Id)), Chars => Chars (Body_Id)),
Parameter_Specifications => Plist, Parameter_Specifications => Plist,
Subtype_Mark => New_Occurrence_Of (Etype (Body_Id), Loc)); Result_Definition =>
New_Occurrence_Of (Etype (Body_Id), Loc));
end if; end if;
Decl := Decl :=
@ -2097,7 +2147,7 @@ package body Sem_Ch6 is
-- to be resolved. -- to be resolved.
if Ekind (Subp) = E_Function then if Ekind (Subp) = E_Function then
Set_Subtype_Mark (Specification (Body_To_Analyze), Set_Result_Definition (Specification (Body_To_Analyze),
New_Occurrence_Of (Etype (Subp), Sloc (N))); New_Occurrence_Of (Etype (Subp), Sloc (N)));
end if; end if;
@ -2167,13 +2217,14 @@ package body Sem_Ch6 is
----------------------- -----------------------
procedure Check_Conformance procedure Check_Conformance
(New_Id : Entity_Id; (New_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
Ctype : Conformance_Type; Ctype : Conformance_Type;
Errmsg : Boolean; Errmsg : Boolean;
Conforms : out Boolean; Conforms : out Boolean;
Err_Loc : Node_Id := Empty; Err_Loc : Node_Id := Empty;
Get_Inst : Boolean := False) Get_Inst : Boolean := False;
Skip_Controlling_Formals : Boolean := False)
is is
Old_Type : constant Entity_Id := Etype (Old_Id); Old_Type : constant Entity_Id := Etype (Old_Id);
New_Type : constant Entity_Id := Etype (New_Id); New_Type : constant Entity_Id := Etype (New_Id);
@ -2255,6 +2306,21 @@ package body Sem_Ch6 is
return; return;
end if; end if;
-- Ada 2005 (AI-231): In case of anonymous access types check the
-- null-exclusion and access-to-constant attributes must match.
if Ada_Version >= Ada_05
and then Ekind (Etype (Old_Type)) = E_Anonymous_Access_Type
and then
(Can_Never_Be_Null (Old_Type)
/= Can_Never_Be_Null (New_Type)
or else Is_Access_Constant (Etype (Old_Type))
/= Is_Access_Constant (Etype (New_Type)))
then
Conformance_Error ("return type does not match!", New_Id);
return;
end if;
-- If either is a function/operator and the other isn't, error -- If either is a function/operator and the other isn't, error
elsif Old_Type /= Standard_Void_Type elsif Old_Type /= Standard_Void_Type
@ -2311,6 +2377,13 @@ package body Sem_Ch6 is
New_Formal := First_Formal (New_Id); New_Formal := First_Formal (New_Id);
while Present (Old_Formal) and then Present (New_Formal) loop while Present (Old_Formal) and then Present (New_Formal) loop
if Is_Controlling_Formal (Old_Formal)
and then Is_Controlling_Formal (New_Formal)
and then Skip_Controlling_Formals
then
goto Skip_Controlling_Formal;
end if;
if Ctype = Fully_Conformant then if Ctype = Fully_Conformant then
-- Names must match. Error message is more accurate if we do -- Names must match. Error message is more accurate if we do
@ -2362,10 +2435,29 @@ package body Sem_Ch6 is
if Ctype = Fully_Conformant then if Ctype = Fully_Conformant then
-- We have checked already that names match. Check default -- We have checked already that names match
-- expressions for in parameters
if Parameter_Mode (Old_Formal) = E_In_Parameter then if Parameter_Mode (Old_Formal) = E_In_Parameter then
-- Ada 2005 (AI-231): In case of anonymous access types check
-- the null-exclusion and access-to-constant attributes must
-- match.
if Ada_Version >= Ada_05
and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
and then
(Can_Never_Be_Null (Old_Formal)
/= Can_Never_Be_Null (New_Formal)
or else Is_Access_Constant (Etype (Old_Formal))
/= Is_Access_Constant (Etype (New_Formal)))
then
Conformance_Error
("type of & does not match!", New_Formal);
return;
end if;
-- Check default expressions for in parameters
declare declare
NewD : constant Boolean := NewD : constant Boolean :=
Present (Default_Value (New_Formal)); Present (Default_Value (New_Formal));
@ -2448,6 +2540,10 @@ package body Sem_Ch6 is
end; end;
end if; end if;
-- This label is required when skipping controlling formals
<<Skip_Controlling_Formal>>
Next_Formal (Old_Formal); Next_Formal (Old_Formal);
Next_Formal (New_Formal); Next_Formal (New_Formal);
end loop; end loop;
@ -3237,6 +3333,12 @@ package body Sem_Ch6 is
then then
return True; return True;
elsif From_With_Type (T2)
and then Ekind (T2) = E_Incomplete_Type
and then T1 = Non_Limited_View (T2)
then
return True;
else else
return False; return False;
end if; end if;
@ -4489,7 +4591,7 @@ package body Sem_Ch6 is
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Op_Name, Defining_Unit_Name => Op_Name,
Parameter_Specifications => Formals, Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc))); Result_Definition => New_Reference_To (Standard_Boolean, Loc)));
-- Insert inequality right after equality if it is explicit or after -- Insert inequality right after equality if it is explicit or after
-- the derived type when implicit. These entities are created only for -- the derived type when implicit. These entities are created only for
@ -4925,6 +5027,15 @@ package body Sem_Ch6 is
if Comes_From_Source (E) then if Comes_From_Source (E) then
Check_Overriding_Indicator (E, True); Check_Overriding_Indicator (E, True);
-- Indicate that E overrides the operation from which
-- S is inherited.
if Present (Alias (S)) then
Set_Overridden_Operation (E, Alias (S));
else
Set_Overridden_Operation (E, S);
end if;
end if; end if;
return; return;
@ -5081,6 +5192,17 @@ package body Sem_Ch6 is
Set_Is_Overriding_Operation (S); Set_Is_Overriding_Operation (S);
Check_Overriding_Indicator (S, True); Check_Overriding_Indicator (S, True);
-- Indicate that S overrides the operation from which
-- E is inherited.
if Comes_From_Source (S) then
if Present (Alias (E)) then
Set_Overridden_Operation (S, Alias (E));
else
Set_Overridden_Operation (S, E);
end if;
end if;
if Is_Dispatching_Operation (E) then if Is_Dispatching_Operation (E) then
-- An overriding dispatching subprogram inherits the -- An overriding dispatching subprogram inherits the
@ -5089,28 +5211,33 @@ package body Sem_Ch6 is
Set_Convention (S, Convention (E)); Set_Convention (S, Convention (E));
-- AI-251: If the subprogram implements an interface, -- AI-251: For an entity overriding an interface
-- check if this subprogram covers other interface -- primitive check if the entity also covers other
-- subprograms available in the same scope. -- abstract subprograms in the same scope. This is
-- required to handle the general case, that is,
-- 1) overriding other interface primitives, and
-- 2) overriding abstract subprograms inherited from
-- some abstract ancestor type.
if Present (Alias (E)) if Has_Homonym (E)
and then Present (Alias (E))
and then Ekind (Alias (E)) /= E_Operator and then Ekind (Alias (E)) /= E_Operator
and then Present (DTC_Entity (Alias (E))) and then Present (DTC_Entity (Alias (E)))
and then Is_Interface (Scope (DTC_Entity and then Is_Interface (Scope (DTC_Entity
(Alias (E)))) (Alias (E))))
then then
Check_Dispatching_Operation (S, E);
declare declare
E1 : Entity_Id; E1 : Entity_Id;
begin begin
E1 := Homonym (E); E1 := Homonym (E);
while Present (E1) loop while Present (E1) loop
if Present (Alias (E1)) if (Is_Overloadable (E1)
or else Ekind (E1) = E_Subprogram_Type)
and then Present (Alias (E1))
and then Ekind (Alias (E1)) /= E_Operator and then Ekind (Alias (E1)) /= E_Operator
and then Present (DTC_Entity (Alias (E1))) and then Present (DTC_Entity (Alias (E1)))
and then Is_Interface and then Is_Abstract
(Scope (DTC_Entity (Alias (E1)))) (Scope (DTC_Entity (Alias (E1))))
and then Type_Conformant (E1, S) and then Type_Conformant (E1, S)
then then
@ -5120,10 +5247,10 @@ package body Sem_Ch6 is
E1 := Homonym (E1); E1 := Homonym (E1);
end loop; end loop;
end; end;
else
Check_Dispatching_Operation (S, E);
end if; end if;
Check_Dispatching_Operation (S, E);
else else
Check_Dispatching_Operation (S, Empty); Check_Dispatching_Operation (S, Empty);
end if; end if;
@ -5292,69 +5419,20 @@ package body Sem_Ch6 is
-- formal in the enclosing scope. Finally, replace the parameter -- formal in the enclosing scope. Finally, replace the parameter
-- type of the formal with the internal subtype. -- type of the formal with the internal subtype.
if Null_Exclusion_Present (Param_Spec) then if Ada_Version >= Ada_05
declare and then Is_Access_Type (Formal_Type)
Loc : constant Source_Ptr := Sloc (Param_Spec); and then Null_Exclusion_Present (Param_Spec)
Anon : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Curr_Scope : constant Scope_Stack_Entry :=
Scope_Stack.Table (Scope_Stack.Last);
Ptype : constant Node_Id := Parameter_Type (Param_Spec);
Decl : Node_Id;
P : Node_Id := Parent (Related_Nod);
begin
Set_Is_Internal (Anon);
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => Anon,
Null_Exclusion_Present => True,
Subtype_Indication =>
New_Occurrence_Of (Etype (Ptype), Loc));
-- Propagate the null-excluding attribute to the new entity
if Null_Exclusion_Present (Param_Spec) then
Set_Null_Exclusion_Present (Param_Spec, False);
Set_Can_Never_Be_Null (Anon);
end if;
Mark_Rewrite_Insertion (Decl);
-- Insert the new declaration in the nearest enclosing scope
-- in front of the subprogram or entry declaration.
while not Is_List_Member (P) loop
P := Parent (P);
end loop;
Insert_Before (P, Decl);
Rewrite (Ptype, New_Occurrence_Of (Anon, Loc));
Mark_Rewrite_Insertion (Ptype);
-- Analyze the new declaration in the context of the
-- enclosing scope
Scope_Stack.Decrement_Last;
Analyze (Decl);
Scope_Stack.Append (Curr_Scope);
Formal_Type := Anon;
end;
end if;
-- Ada 2005 (AI-231): Static checks
if Null_Exclusion_Present (Param_Spec)
or else Can_Never_Be_Null (Entity (Ptype))
then then
Null_Exclusion_Static_Checks (Param_Spec); if Can_Never_Be_Null (Formal_Type) then
Error_Msg_N
("(Ada 2005) already a null-excluding type", Related_Nod);
end if;
Formal_Type :=
Create_Null_Excluding_Itype
(T => Formal_Type,
Related_Nod => Related_Nod,
Scope_Id => Scope (Current_Scope));
end if; end if;
-- An access formal type -- An access formal type
@ -5407,6 +5485,15 @@ package body Sem_Ch6 is
end if; end if;
end if; end if;
-- Ada 2005 (AI-231): Static checks
if Ada_Version >= Ada_05
and then Is_Access_Type (Etype (Formal))
and then Can_Never_Be_Null (Etype (Formal))
then
Null_Exclusion_Static_Checks (Param_Spec);
end if;
<<Continue>> <<Continue>>
Next (Param_Spec); Next (Param_Spec);
end loop; end loop;
@ -5663,20 +5750,18 @@ package body Sem_Ch6 is
-- null; In Ada 2005, only if then null_exclusion is explicit. -- null; In Ada 2005, only if then null_exclusion is explicit.
if Ada_Version < Ada_05 if Ada_Version < Ada_05
or else Null_Exclusion_Present (Spec)
or else Can_Never_Be_Null (Etype (Formal_Id)) or else Can_Never_Be_Null (Etype (Formal_Id))
then then
Set_Is_Known_Non_Null (Formal_Id); Set_Is_Known_Non_Null (Formal_Id);
Set_Can_Never_Be_Null (Formal_Id); Set_Can_Never_Be_Null (Formal_Id);
end if; end if;
-- Ada 2005 (AI-231): Null-exclusion access subtype
elsif Is_Access_Type (Etype (Formal_Id)) elsif Is_Access_Type (Etype (Formal_Id))
and then Can_Never_Be_Null (Etype (Formal_Id)) and then Can_Never_Be_Null (Etype (Formal_Id))
then then
-- Ada 2005: The access subtype may be declared with null-exclusion
Set_Is_Known_Non_Null (Formal_Id); Set_Is_Known_Non_Null (Formal_Id);
Set_Can_Never_Be_Null (Formal_Id);
end if; end if;
Set_Mechanism (Formal_Id, Default_Mechanism); Set_Mechanism (Formal_Id, Default_Mechanism);
@ -5734,10 +5819,16 @@ package body Sem_Ch6 is
-- Type_Conformant -- -- Type_Conformant --
--------------------- ---------------------
function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is function Type_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Skip_Controlling_Formals : Boolean := False) return Boolean
is
Result : Boolean; Result : Boolean;
begin begin
Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result); Check_Conformance
(New_Id, Old_Id, Type_Conformant, False, Result,
Skip_Controlling_Formals => Skip_Controlling_Formals);
return Result; return Result;
end Type_Conformant; end Type_Conformant;
@ -5753,7 +5844,6 @@ package body Sem_Ch6 is
begin begin
F := First_Formal (Designator); F := First_Formal (Designator);
while Present (F) loop while Present (F) loop
N := N + 1; N := N + 1;

20
gcc/ada/sem_ch6.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -143,11 +143,10 @@ package Sem_Ch6 is
procedure New_Overloaded_Entity procedure New_Overloaded_Entity
(S : Entity_Id; (S : Entity_Id;
Derived_Type : Entity_Id := Empty); Derived_Type : Entity_Id := Empty);
-- Process new overloaded entity. Overloaded entities are created -- Process new overloaded entity. Overloaded entities are created by
-- by enumeration type declarations, subprogram specifications, -- enumeration type declarations, subprogram specifications, entry
-- entry declarations, and (implicitly) by type derivations. -- declarations, and (implicitly) by type derivations. Derived_Type non-
-- If Derived_Type is not Empty, then it indicates that this -- Empty indicates that this is subprogram derived for that type.
-- is subprogram derived for that type.
procedure Process_Formals (T : List_Id; Related_Nod : Node_Id); procedure Process_Formals (T : List_Id; Related_Nod : Node_Id);
-- Enter the formals in the scope of the subprogram or entry, and -- Enter the formals in the scope of the subprogram or entry, and
@ -168,11 +167,14 @@ package Sem_Ch6 is
function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries, -- Determine whether two callable entities (subprograms, entries,
-- literals) are subtype conformant (RM6.3.1(16)) -- literals) are subtype conformant (RM6.3.1(16)).
function Type_Conformant (New_Id, Old_Id : Entity_Id) return Boolean; function Type_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Skip_Controlling_Formals : Boolean := False) return Boolean;
-- Determine whether two callable entities (subprograms, entries, -- Determine whether two callable entities (subprograms, entries,
-- literals) are type conformant (RM6.3.1(14)) -- literals) are type conformant (RM6.3.1(14)).
procedure Valid_Operator_Definition (Designator : Entity_Id); procedure Valid_Operator_Definition (Designator : Entity_Id);
-- Verify that an operator definition has the proper number of formals -- Verify that an operator definition has the proper number of formals