Skip to content

R
riscv-gcc-1
Commit 468c6c8a by Ed Schonberg Committed by Arnaud Charlet
Options

sem_attr.ads, [...] (Analyze_Access_Attribute): Diagnose properly an attempt to… 

sem_attr.ads, [...] (Analyze_Access_Attribute): Diagnose properly an attempt to apply Unchecked_Access to a protected operation.

2006-10-31  Ed Schonberg  <schonberg@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* sem_attr.ads, sem_attr.adb (Analyze_Access_Attribute): Diagnose
	properly an attempt to apply Unchecked_Access to a protected operation.
	(OK_Self_Reference): New subprogram to check the legality of an access
	attribute whose prefix is the type of an enclosing aggregate.
	Generalizes previous mechanism to handle attribute references nested
	arbitrarily deep within the aggregate.
	(Analyze_Access_Attribute): An access attribute whose prefix is a type
	can appear in an aggregate if this is a default-initialized aggregate
	for a self-referential type.
	(Resolve_Attribute, case Access): Ditto.
	Add support for new implementation defined attribute Stub_Type.
	(Eval_Attribute, case Attribute_Stub_Type): New case.
	(Analyze_Attribute, case Attribute_Stub_Type): New case.
	(Stream_Attribute_Available): Implement using new subprogram from
	sem_cat, Has_Stream_Attribute_Definition, instead of incorrect
	Has_Specified_Stream_Attribute flag.
	Disallow Storage_Size and Storage_Pool for access to subprogram
	(Resolve_Attribute, case 'Access et al): Take into account anonymous
	access types of return subtypes in extended return statements. Remove
	accessibility checks on anonymous access types when Unchecked_Access is
	used.
	(Analyze_Attribute): Add support for the use of 'Class to convert
	a class-wide interface to a tagged type.
	Add support for the attribute Priority.
	(Resolve_Attribute, case Attribute_Access): For Ada_05, add test for
	whether the designated type is discriminated with a constrained partial
	view and require static matching in that case.
	Add local variable Des_Btyp. The Designated_Type
	of an access to incomplete subtype is either its non-limited view if
	coming from a limited with or its etype if regular incomplete subtype.

	* sem_cat.ads, sem_cat.adb (Validate_Remote_Access_To_Class_Wide_Type):
	Fix predicate to identify and allow cases of (expander-generated)
	references to tag of designated object of a RACW.
	(Validate_Static_Object_Name): In Ada 2005, a formal object is
	non-static, and therefore cannot appear as a primary in a preelaborable
	package.
	(Has_Stream_Attribute_Definition): New subprogram, abstracted from
	Has_Read_Write_Attributes.
	(Has_Read_Write_Attributes): Reimplement in termes of
	Has_Stream_Attribute_Definition.
	(Missing_Read_Write_Attributes): When checking component types in a
	record, unconditionally call Missing_Read_Write_Attributes recursively
	(remove guard checking for Is_Record_Type / Is_Access_Type).

From-SVN: r118298
parent daca8389
Showing with 562 additions and 257 deletions
gcc/ada/sem_attr.adb
...@@ -31,6 +31,7 @@ with Checks; use Checks; ...@@ -31,6 +31,7 @@ with Checks; use Checks;
with Einfo; use Einfo; with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Eval_Fat; with Eval_Fat;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Expander; use Expander; with Expander; use Expander;
with Freeze; use Freeze; with Freeze; use Freeze;
...@@ -342,6 +343,11 @@ package body Sem_Attr is ...@@ -342,6 +343,11 @@ package body Sem_Attr is
-- the type of the prefix. If prefix is overloaded, so it the -- the type of the prefix. If prefix is overloaded, so it the
-- node itself. The result is stored in Acc_Type. -- node itself. The result is stored in Acc_Type.
function OK_Self_Reference return Boolean;
-- An access reference whose prefix is a type can legally appear
-- within an aggregate, where it is obtained by expansion of
-- a defaulted aggregate;
------------------------------ ------------------------------
-- Build_Access_Object_Type -- -- Build_Access_Object_Type --
------------------------------ ------------------------------
...@@ -432,6 +438,36 @@ package body Sem_Attr is ...@@ -432,6 +438,36 @@ package body Sem_Attr is
end if; end if;
end Build_Access_Subprogram_Type; end Build_Access_Subprogram_Type;
----------------------
-- OK_Self_Reference --
----------------------
function OK_Self_Reference return Boolean is
Par : Node_Id;
begin
Par := Parent (N);
while Present (Par)
and then Nkind (Par) in N_Subexpr
loop
exit when Nkind (Par) = N_Aggregate
or else Nkind (Par) = N_Extension_Aggregate;
Par := Parent (Par);
end loop;
if Present (Par)
and then
(Nkind (Par) = N_Aggregate
or else Nkind (Par) = N_Extension_Aggregate)
and then Etype (Par) = Typ
then
Set_Has_Self_Reference (Par);
return True;
else
return False;
end if;
end OK_Self_Reference;
-- Start of processing for Analyze_Access_Attribute -- Start of processing for Analyze_Access_Attribute
begin begin
...@@ -460,6 +496,10 @@ package body Sem_Attr is ...@@ -460,6 +496,10 @@ package body Sem_Attr is
P); P);
end if; end if;
if Aname = Name_Unchecked_Access then
Error_Attr ("attribute% cannot be applied to a subprogram", P);
end if;
-- Build the appropriate subprogram type -- Build the appropriate subprogram type
Build_Access_Subprogram_Type (P); Build_Access_Subprogram_Type (P);
...@@ -488,7 +528,9 @@ package body Sem_Attr is ...@@ -488,7 +528,9 @@ package body Sem_Attr is
end if; end if;
-- Deal with incorrect reference to a type, but note that some -- Deal with incorrect reference to a type, but note that some
-- accesses are allowed (references to the current type instance). -- accesses are allowed: references to the current type instance,
-- or in Ada 2005 self-referential pointer in a default-initialized
-- aggregate.
if Is_Entity_Name (P) then if Is_Entity_Name (P) then
Typ := Entity (P); Typ := Entity (P);
...@@ -570,6 +612,15 @@ package body Sem_Attr is ...@@ -570,6 +612,15 @@ package body Sem_Attr is
elsif Is_Task_Type (Typ) then elsif Is_Task_Type (Typ) then
null; null;
-- OK if self-reference in an aggregate in Ada 2005, and
-- the reference comes from a copied default expression.
elsif Ada_Version >= Ada_05
and then not Comes_From_Source (N)
and then OK_Self_Reference
then
null;
-- Otherwise we have an error case -- Otherwise we have an error case
else else
...@@ -985,7 +1036,6 @@ package body Sem_Attr is ...@@ -985,7 +1036,6 @@ package body Sem_Attr is
procedure Check_Enum_Image is procedure Check_Enum_Image is
Lit : Entity_Id; Lit : Entity_Id;
begin begin
if Is_Enumeration_Type (P_Base_Type) then if Is_Enumeration_Type (P_Base_Type) then
Lit := First_Literal (P_Base_Type); Lit := First_Literal (P_Base_Type);
...@@ -1277,6 +1327,7 @@ package body Sem_Attr is ...@@ -1277,6 +1327,7 @@ package body Sem_Attr is
procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id; Etyp : Entity_Id;
Btyp : Entity_Id; Btyp : Entity_Id;
begin begin
Validate_Non_Static_Attribute_Function_Call; Validate_Non_Static_Attribute_Function_Call;
...@@ -1561,6 +1612,8 @@ package body Sem_Attr is ...@@ -1561,6 +1612,8 @@ package body Sem_Attr is
return False; return False;
end On_X86; end On_X86;
-- Start of processing for Alignment_Kludge
begin begin
if Aname = Name_Maximum_Alignment and then On_X86 then if Aname = Name_Maximum_Alignment and then On_X86 then
P := Parent (N); P := Parent (N);
...@@ -1673,7 +1726,6 @@ package body Sem_Attr is ...@@ -1673,7 +1726,6 @@ package body Sem_Attr is
elsif Entity (P) = Current_Scope elsif Entity (P) = Current_Scope
and then Is_Record_Type (Entity (P)) and then Is_Record_Type (Entity (P))
then then
-- Use of current instance within the type. Verify that if the -- Use of current instance within the type. Verify that if the
-- attribute appears within a constraint, it yields an access -- attribute appears within a constraint, it yields an access
-- type, other uses are illegal. -- type, other uses are illegal.
...@@ -1779,7 +1831,6 @@ package body Sem_Attr is ...@@ -1779,7 +1831,6 @@ package body Sem_Attr is
begin begin
Get_First_Interp (P, I, It); Get_First_Interp (P, I, It);
while Present (It.Nam) loop while Present (It.Nam) loop
if Comes_From_Source (It.Nam) then if Comes_From_Source (It.Nam) then
Count := Count + 1; Count := Count + 1;
...@@ -2329,15 +2380,16 @@ package body Sem_Attr is ...@@ -2329,15 +2380,16 @@ package body Sem_Attr is
Save_Interps (E1, Expression (N)); Save_Interps (E1, Expression (N));
if not Is_Interface (Etype (P)) then
Analyze (N);
-- Ada 2005 (AI-251): In case of abstract interfaces we have to -- Ada 2005 (AI-251): In case of abstract interfaces we have to
-- analyze and resolve the type conversion to generate the code -- analyze and resolve the type conversion to generate the code
-- that displaces the reference to the base of the object. -- that displaces the reference to the base of the object.
else if Is_Interface (Etype (P))
or else Is_Interface (Etype (E1))
then
Analyze_And_Resolve (N, Etype (P)); Analyze_And_Resolve (N, Etype (P));
else
Analyze (N);
end if; end if;
-- Otherwise we just need to find the proper type -- Otherwise we just need to find the proper type
...@@ -3410,6 +3462,56 @@ package body Sem_Attr is ...@@ -3410,6 +3462,56 @@ package body Sem_Attr is
end if; end if;
end if; end if;
--------------
-- Priority --
--------------
-- Ada 2005 (AI-327): Dynamic ceiling priorities
when Attribute_Priority =>
if Ada_Version < Ada_05 then
Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
end if;
Check_E0;
-- The prefix must be a protected object (AARM D.5.2 (2/2))
Analyze (P);
if Is_Protected_Type (Etype (P))
or else (Is_Access_Type (Etype (P))
and then Is_Protected_Type (Designated_Type (Etype (P))))
then
Resolve (P, Etype (P));
else
Error_Attr ("prefix of % attribute must be a protected object", P);
end if;
Set_Etype (N, Standard_Integer);
-- Must be called from within a protected procedure or entry of the
-- protected object.
declare
S : Entity_Id;
begin
S := Current_Scope;
while S /= Etype (P)
and then S /= Standard_Standard
loop
S := Scope (S);
end loop;
if S = Standard_Standard then
Error_Attr ("the attribute % is only allowed inside protected "
& "operations", P);
end if;
end;
Validate_Non_Static_Attribute_Function_Call;
----------- -----------
-- Range -- -- Range --
----------- -----------
...@@ -3619,6 +3721,11 @@ package body Sem_Attr is ...@@ -3619,6 +3721,11 @@ package body Sem_Attr is
if Is_Access_Type (P_Type) then if Is_Access_Type (P_Type) then
Check_E0; Check_E0;
if Ekind (P_Type) = E_Access_Subprogram_Type then
Error_Attr
("cannot use % attribute for access-to-subprogram type", P);
end if;
-- Set appropriate entity -- Set appropriate entity
if Present (Associated_Storage_Pool (Root_Type (P_Type))) then if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
...@@ -3644,12 +3751,16 @@ package body Sem_Attr is ...@@ -3644,12 +3751,16 @@ package body Sem_Attr is
------------------ ------------------
when Attribute_Storage_Size => when Attribute_Storage_Size =>
if Is_Task_Type (P_Type) then if Is_Task_Type (P_Type) then
Check_E0; Check_E0;
Set_Etype (N, Universal_Integer); Set_Etype (N, Universal_Integer);
elsif Is_Access_Type (P_Type) then elsif Is_Access_Type (P_Type) then
if Ekind (P_Type) = E_Access_Subprogram_Type then
Error_Attr
("cannot use % attribute for access-to-subprogram type", P);
end if;
if Is_Entity_Name (P) if Is_Entity_Name (P)
and then Is_Type (Entity (P)) and then Is_Type (Entity (P))
then then
...@@ -3700,6 +3811,22 @@ package body Sem_Attr is ...@@ -3700,6 +3811,22 @@ package body Sem_Attr is
Error_Attr ("invalid prefix for % attribute", P); Error_Attr ("invalid prefix for % attribute", P);
end if; end if;
---------------
-- Stub_Type --
---------------
when Attribute_Stub_Type =>
Check_Type;
Check_E0;
if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
Rewrite (N,
New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
else
Error_Attr
("prefix of% attribute must be remote access to classwide", P);
end if;
---------- ----------
-- Succ -- -- Succ --
---------- ----------
...@@ -6725,10 +6852,12 @@ package body Sem_Attr is ...@@ -6725,10 +6852,12 @@ package body Sem_Attr is
Attribute_Partition_ID | Attribute_Partition_ID |
Attribute_Pool_Address | Attribute_Pool_Address |
Attribute_Position | Attribute_Position |
Attribute_Priority |
Attribute_Read | Attribute_Read |
Attribute_Storage_Pool | Attribute_Storage_Pool |
Attribute_Storage_Size | Attribute_Storage_Size |
Attribute_Storage_Unit | Attribute_Storage_Unit |
Attribute_Stub_Type |
Attribute_Tag | Attribute_Tag |
Attribute_Target_Name | Attribute_Target_Name |
Attribute_Terminated | Attribute_Terminated |
...@@ -6807,6 +6936,7 @@ package body Sem_Attr is ...@@ -6807,6 +6936,7 @@ package body Sem_Attr is
Aname : constant Name_Id := Attribute_Name (N); Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname); Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
Btyp : constant Entity_Id := Base_Type (Typ); Btyp : constant Entity_Id := Base_Type (Typ);
Des_Btyp : Entity_Id;
Index : Interp_Index; Index : Interp_Index;
It : Interp; It : Interp;
Nom_Subt : Entity_Id; Nom_Subt : Entity_Id;
...@@ -7170,6 +7300,8 @@ package body Sem_Attr is ...@@ -7170,6 +7300,8 @@ package body Sem_Attr is
-- X'Access is illegal if X denotes a constant and the access -- X'Access is illegal if X denotes a constant and the access
-- type is access-to-variable. Same for 'Unchecked_Access. -- type is access-to-variable. Same for 'Unchecked_Access.
-- The rule does not apply to 'Unrestricted_Access. -- The rule does not apply to 'Unrestricted_Access.
-- If the reference is a default-initialized aggregate component
-- for a self-referential type the reference is legal.
if not (Ekind (Btyp) = E_Access_Subprogram_Type if not (Ekind (Btyp) = E_Access_Subprogram_Type
or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
...@@ -7182,7 +7314,15 @@ package body Sem_Attr is ...@@ -7182,7 +7314,15 @@ package body Sem_Attr is
or else Is_Variable (P) or else Is_Variable (P)
or else Attr_Id = Attribute_Unrestricted_Access) or else Attr_Id = Attribute_Unrestricted_Access)
then then
if Comes_From_Source (N) then if Is_Entity_Name (P)
and then Is_Type (Entity (P))
then
-- Legality of a self-reference through an access
-- attribute has been verified in Analyze_Access_Attribute.
null;
elsif Comes_From_Source (N) then
Error_Msg_N ("access-to-variable designates constant", P); Error_Msg_N ("access-to-variable designates constant", P);
end if; end if;
end if; end if;
...@@ -7199,8 +7339,11 @@ package body Sem_Attr is ...@@ -7199,8 +7339,11 @@ package body Sem_Attr is
-- enclosing composite type. -- enclosing composite type.
if Ada_Version >= Ada_05 if Ada_Version >= Ada_05
and then Is_Local_Anonymous_Access (Btyp) and then
(Is_Local_Anonymous_Access (Btyp)
or else Ekind (Scope (Btyp)) = E_Return_Statement)
and then Object_Access_Level (P) > Type_Access_Level (Btyp) and then Object_Access_Level (P) > Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
then then
-- In an instance, this is a runtime check, but one we -- In an instance, this is a runtime check, but one we
-- know will fail, so generate an appropriate warning. -- know will fail, so generate an appropriate warning.
...@@ -7236,6 +7379,23 @@ package body Sem_Attr is ...@@ -7236,6 +7379,23 @@ package body Sem_Attr is
Nom_Subt := Etype (Nom_Subt); Nom_Subt := Etype (Nom_Subt);
end if; end if;
Des_Btyp := Designated_Type (Btyp);
if Ekind (Des_Btyp) = E_Incomplete_Subtype then
-- Ada 2005 (AI-412): Subtypes of incomplete types visible
-- through a limited with clause or regular incomplete
-- subtypes.
if From_With_Type (Des_Btyp)
and then Present (Non_Limited_View (Des_Btyp))
then
Des_Btyp := Non_Limited_View (Des_Btyp);
else
Des_Btyp := Etype (Des_Btyp);
end if;
end if;
if Is_Tagged_Type (Designated_Type (Typ)) then if Is_Tagged_Type (Designated_Type (Typ)) then
-- If the attribute is in the context of an access -- If the attribute is in the context of an access
...@@ -7291,13 +7451,22 @@ package body Sem_Attr is ...@@ -7291,13 +7451,22 @@ package body Sem_Attr is
(N, Etype (Designated_Type (Typ))); (N, Etype (Designated_Type (Typ)));
end if; end if;
elsif not Subtypes_Statically_Match -- Ada 2005 (AI-363): Require static matching when designated
(Designated_Type (Base_Type (Typ)), Nom_Subt) -- type has discriminants and a constrained partial view, since
-- in general objects of such types are mutable, so we can't
-- allow the access value to designate a constrained object
-- (because access values must be assumed to designate mutable
-- objects when designated type does not impose a constraint).
elsif not Subtypes_Statically_Match (Des_Btyp, Nom_Subt)
and then and then
not (Has_Discriminants (Designated_Type (Typ)) not (Has_Discriminants (Designated_Type (Typ))
and then not Is_Constrained (Des_Btyp)
and then and then
not Is_Constrained (Ada_Version < Ada_05
(Designated_Type (Base_Type (Typ)))) or else
not Has_Constrained_Partial_View
(Designated_Type (Base_Type (Typ)))))
then then
Error_Msg_N Error_Msg_N
("object subtype must statically match " ("object subtype must statically match "
...@@ -7306,7 +7475,6 @@ package body Sem_Attr is ...@@ -7306,7 +7475,6 @@ package body Sem_Attr is
if Is_Entity_Name (P) if Is_Entity_Name (P)
and then Is_Array_Type (Designated_Type (Typ)) and then Is_Array_Type (Designated_Type (Typ))
then then
declare declare
D : constant Node_Id := Declaration_Node (Entity (P)); D : constant Node_Id := Declaration_Node (Entity (P));
...@@ -7795,42 +7963,12 @@ package body Sem_Attr is ...@@ -7795,42 +7963,12 @@ package body Sem_Attr is
is is
Etyp : Entity_Id := Typ; Etyp : Entity_Id := Typ;
function Has_Specified_Stream_Attribute
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Boolean;
-- True iff there is a visible attribute definition clause specifying
-- attribute Nam for Typ.
------------------------------------
-- Has_Specified_Stream_Attribute --
------------------------------------
function Has_Specified_Stream_Attribute
(Typ : Entity_Id;
Nam : TSS_Name_Type) return Boolean
is
begin
return False
or else
(Nam = TSS_Stream_Input
and then Has_Specified_Stream_Input (Typ))
or else
(Nam = TSS_Stream_Output
and then Has_Specified_Stream_Output (Typ))
or else
(Nam = TSS_Stream_Read
and then Has_Specified_Stream_Read (Typ))
or else
(Nam = TSS_Stream_Write
and then Has_Specified_Stream_Write (Typ));
end Has_Specified_Stream_Attribute;
-- Start of processing for Stream_Attribute_Available -- Start of processing for Stream_Attribute_Available
begin begin
-- We need some comments in this body ??? -- We need some comments in this body ???
if Has_Specified_Stream_Attribute (Typ, Nam) then if Has_Stream_Attribute_Definition (Typ, Nam) then
return True; return True;
end if; end if;
...@@ -7874,7 +8012,7 @@ package body Sem_Attr is ...@@ -7874,7 +8012,7 @@ package body Sem_Attr is
while Etype (Etyp) /= Etyp loop while Etype (Etyp) /= Etyp loop
Etyp := Etype (Etyp); Etyp := Etype (Etyp);
if Has_Specified_Stream_Attribute (Etyp, Nam) then if Has_Stream_Attribute_Definition (Etyp, Nam) then
return True; return True;
end if; end if;
end loop; end loop;
......
gcc/ada/sem_attr.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, 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- --
...@@ -78,18 +78,18 @@ package Sem_Attr is ...@@ -78,18 +78,18 @@ package Sem_Attr is
--------------- ---------------
Attribute_Asm_Input => True, Attribute_Asm_Input => True,
-- Used only in conjunction with the Asm and Asm_Volatile subprograms -- Used only in conjunction with the Asm subprograms in package
-- in package Machine_Code to construct machine instructions. See -- Machine_Code to construct machine instructions. See documentation
-- documentation in package Machine_Code in file s-maccod.ads. -- in package Machine_Code in file s-maccod.ads.
---------------- ----------------
-- Asm_Output -- -- Asm_Output --
---------------- ----------------
Attribute_Asm_Output => True, Attribute_Asm_Output => True,
-- Used only in conjunction with the Asm and Asm_Volatile subprograms -- Used only in conjunction with the Asm subprograms in package
-- in package Machine_Code to construct machine instructions. See -- Machine_Code to construct machine instructions. See documentation
-- documentation in package Machine_Code in file s-maccod.ads. -- in package Machine_Code in file s-maccod.ads.
--------------- ---------------
-- AST_Entry -- -- AST_Entry --
...@@ -382,6 +382,27 @@ package Sem_Attr is ...@@ -382,6 +382,27 @@ package Sem_Attr is
-- for constructing this definition in package System (see note above -- for constructing this definition in package System (see note above
-- in Default_Bit_Order description). The is a static attribute. -- in Default_Bit_Order description). The is a static attribute.
---------------
-- Stub_Type --
---------------
Attribute_Stub_Type => True,
-- The GNAT implementation of remote access-to-classwide types is
-- organised as described in AARM E.4(20.t): a value of an RACW type
-- (designating a remote object) is represented as a normal access
-- value, pointing to a "stub" object which in turn contains the
-- necessary information to contact the designated remote object. A
-- call on any dispatching operation of such a stub object does the
-- remote call, if necessary, using the information in the stub object
-- to locate the target partition, etc.
--
-- For a prefix T that denotes a remote access-to-classwide type,
-- T'Stub_Type denotes the type of the corresponding stub objects.
--
-- By construction, the layout of T'Stub_Type is identical to that of
-- System.Partition_Interface.RACW_Stub_Type (see implementation notes
-- in body of Exp_Dist).
----------------- -----------------
-- Target_Name -- -- Target_Name --
----------------- -----------------
......
gcc/ada/sem_cat.adb
...@@ -29,7 +29,6 @@ with Debug; use Debug; ...@@ -29,7 +29,6 @@ with Debug; use Debug;
with Einfo; use Einfo; with Einfo; use Einfo;
with Elists; use Elists; with Elists; use Elists;
with Errout; use Errout; with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname; with Fname; use Fname;
with Lib; use Lib; with Lib; use Lib;
with Nlists; use Nlists; with Nlists; use Nlists;
...@@ -73,6 +72,8 @@ package body Sem_Cat is ...@@ -73,6 +72,8 @@ package body Sem_Cat is
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean; function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if the entity or one of its subcomponent is an access -- Return True if the entity or one of its subcomponent is an access
-- type which does not have user-defined Read and Write attribute. -- type which does not have user-defined Read and Write attribute.
-- Additionally, in Ada 2005 mode, stream attributes are considered missing
-- if the attribute definition clause is not visible.
function In_RCI_Declaration (N : Node_Id) return Boolean; function In_RCI_Declaration (N : Node_Id) return Boolean;
-- Determines if a declaration is within the visible part of a Remote -- Determines if a declaration is within the visible part of a Remote
...@@ -84,7 +85,8 @@ package body Sem_Cat is ...@@ -84,7 +85,8 @@ package body Sem_Cat is
-- for semantic checking purposes. -- for semantic checking purposes.
function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean;
-- Returns true if the entity is a non-remote access type -- Returns true if the entity is a type whose full view is a non-remote
-- access type, for the purpose of enforcing E.2.2(8) rules.
function In_Shared_Passive_Unit return Boolean; function In_Shared_Passive_Unit return Boolean;
-- Determines if current scope is within a Shared Passive compilation unit -- Determines if current scope is within a Shared Passive compilation unit
...@@ -295,6 +297,51 @@ package body Sem_Cat is ...@@ -295,6 +297,51 @@ package body Sem_Cat is
end loop; end loop;
end Check_Non_Static_Default_Expr; end Check_Non_Static_Default_Expr;
-------------------------------------
-- Has_Stream_Attribute_Definition --
-------------------------------------
function Has_Stream_Attribute_Definition
(Typ : Entity_Id; Nam : TSS_Name_Type) return Boolean
is
Rep_Item : Node_Id;
begin
-- We start from the declaration node and then loop until the end of
-- the list until we find the requested attribute definition clause.
-- In Ada 2005 mode, clauses are ignored if they are not currently
-- visible (this is tested using the corresponding Entity, which is
-- inserted by the expander at the point where the clause occurs).
Rep_Item := First_Rep_Item (Typ);
while Present (Rep_Item) loop
if Nkind (Rep_Item) = N_Attribute_Definition_Clause then
case Chars (Rep_Item) is
when Name_Read =>
exit when Nam = TSS_Stream_Read;
when Name_Write =>
exit when Nam = TSS_Stream_Write;
when Name_Input =>
exit when Nam = TSS_Stream_Input;
when Name_Output =>
exit when Nam = TSS_Stream_Output;
when others =>
null;
end case;
end if;
Next_Rep_Item (Rep_Item);
end loop;
return Present (Rep_Item)
and then (Ada_Version < Ada_05
or else not Is_Hidden (Entity (Rep_Item)));
end Has_Stream_Attribute_Definition;
--------------------------- ---------------------------
-- In_Preelaborated_Unit -- -- In_Preelaborated_Unit --
--------------------------- ---------------------------
...@@ -306,7 +353,7 @@ package body Sem_Cat is ...@@ -306,7 +353,7 @@ package body Sem_Cat is
begin begin
-- There are no constraints on body of remote_call_interface or -- There are no constraints on body of remote_call_interface or
-- remote_types packages.. -- remote_types packages.
return (Unit_Entity /= Standard_Standard) return (Unit_Entity /= Standard_Standard)
and then (Is_Preelaborated (Unit_Entity) and then (Is_Preelaborated (Unit_Entity)
...@@ -422,10 +469,19 @@ package body Sem_Cat is ...@@ -422,10 +469,19 @@ package body Sem_Cat is
------------------------------- -------------------------------
function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is
U_E : constant Entity_Id := Underlying_Type (E);
begin begin
return Is_Access_Type (E) if No (U_E) then
and then not Is_Remote_Access_To_Class_Wide_Type (E)
and then not Is_Remote_Access_To_Subprogram_Type (E); -- This case arises for the case of a generic formal type, in which
-- case E.2.2(8) rules will be enforced at instantiation time.
return False;
end if;
return Is_Access_Type (U_E)
and then not Is_Remote_Access_To_Class_Wide_Type (U_E)
and then not Is_Remote_Access_To_Subprogram_Type (U_E);
end Is_Non_Remote_Access_Type; end Is_Non_Remote_Access_Type;
------------------------------------ ------------------------------------
...@@ -460,60 +516,48 @@ package body Sem_Cat is ...@@ -460,60 +516,48 @@ package body Sem_Cat is
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
Component : Entity_Id; Component : Entity_Id;
Component_Type : Entity_Id; Component_Type : Entity_Id;
U_E : constant Entity_Id := Underlying_Type (E);
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean; function Has_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if entity has Read and Write attributes -- Return True if entity has visible attribute definition clauses for
-- Read and Write attributes.
------------------------------- -------------------------------
-- Has_Read_Write_Attributes -- -- Has_Read_Write_Attributes --
------------------------------- -------------------------------
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
Rep_Item : Node_Id := First_Rep_Item (E);
Read_Attribute : Boolean := False;
Write_Attribute : Boolean := False;
begin begin
-- We start from the declaration node and then loop until the end return True
-- of the list until we find those two attribute definition clauses. and then Has_Stream_Attribute_Definition (E, TSS_Stream_Read)
and then Has_Stream_Attribute_Definition (E, TSS_Stream_Write);
while Present (Rep_Item) loop
if Chars (Rep_Item) = Name_Read then
Read_Attribute := True;
elsif Chars (Rep_Item) = Name_Write then
Write_Attribute := True;
end if;
if Read_Attribute and Write_Attribute then
return True;
end if;
Next_Rep_Item (Rep_Item);
end loop;
return False;
end Has_Read_Write_Attributes; end Has_Read_Write_Attributes;
-- Start of processing for Missing_Read_Write_Attributes -- Start of processing for Missing_Read_Write_Attributes
begin begin
if Has_Read_Write_Attributes (E) then if No (U_E) then
return False;
elsif Has_Read_Write_Attributes (E)
or else Has_Read_Write_Attributes (U_E)
then
return False; return False;
elsif Is_Non_Remote_Access_Type (E) then
elsif Is_Non_Remote_Access_Type (U_E) then
return True; return True;
end if; end if;
if Is_Record_Type (E) then if Is_Record_Type (U_E) then
Component := First_Entity (E); Component := First_Entity (U_E);
while Present (Component) loop while Present (Component) loop
if not Is_Tag (Component) then
Component_Type := Etype (Component); Component_Type := Etype (Component);
if (Is_Non_Remote_Access_Type (Component_Type) if Missing_Read_Write_Attributes (Component_Type) then
or else Is_Record_Type (Component_Type))
and then Missing_Read_Write_Attributes (Component_Type)
then
return True; return True;
end if; end if;
end if;
Next_Entity (Component); Next_Entity (Component);
end loop; end loop;
...@@ -536,16 +580,22 @@ package body Sem_Cat is ...@@ -536,16 +580,22 @@ package body Sem_Cat is
-- the argument of the pragma can be resolved properly, and reset -- the argument of the pragma can be resolved properly, and reset
-- afterwards. -- afterwards.
procedure Set_Parents (Visibility : Boolean) is -----------------
Par : Entity_Id := Scope (S); -- Set_Parents --
-----------------
procedure Set_Parents (Visibility : Boolean) is
Par : Entity_Id;
begin begin
Par := Scope (S);
while Present (Par) and then Par /= Standard_Standard loop while Present (Par) and then Par /= Standard_Standard loop
Set_Is_Immediately_Visible (Par, Visibility); Set_Is_Immediately_Visible (Par, Visibility);
Par := Scope (Par); Par := Scope (Par);
end loop; end loop;
end Set_Parents; end Set_Parents;
-- Start of processing for Set_Categorization_From_Pragmas
begin begin
-- Deal with categorization pragmas in Pragmas of Compilation_Unit. -- Deal with categorization pragmas in Pragmas of Compilation_Unit.
-- The purpose is to set categorization flags before analyzing the -- The purpose is to set categorization flags before analyzing the
...@@ -558,16 +608,16 @@ package body Sem_Cat is ...@@ -558,16 +608,16 @@ package body Sem_Cat is
end if; end if;
declare declare
PN : Node_Id := First (Pragmas_After (Aux_Decls_Node (P))); PN : Node_Id;
begin begin
if Is_Child_Unit (S) if Is_Child_Unit (S)
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
then then
Set_Parents (True); Set_Parents (True);
end if; end if;
PN := First (Pragmas_After (Aux_Decls_Node (P)));
while Present (PN) loop while Present (PN) loop
-- Skip implicit types that may have been introduced by -- Skip implicit types that may have been introduced by
...@@ -588,12 +638,12 @@ package body Sem_Cat is ...@@ -588,12 +638,12 @@ package body Sem_Cat is
Next (PN); Next (PN);
end loop; end loop;
if Is_Child_Unit (S) if Is_Child_Unit (S)
and then Is_Generic_Instance (S) and then Is_Generic_Instance (S)
then then
Set_Parents (False); Set_Parents (False);
end if; end if;
end; end;
end Set_Categorization_From_Pragmas; end Set_Categorization_From_Pragmas;
...@@ -711,11 +761,15 @@ package body Sem_Cat is ...@@ -711,11 +761,15 @@ package body Sem_Cat is
Set_Is_Pure_Unit_Access_Type (T); Set_Is_Pure_Unit_Access_Type (T);
end if; end if;
-- Check for RCI or RT unit type declaration. It should not -- Check for RCI or RT unit type declaration: declaration of an
-- contain the declaration of an access-to-object type unless it -- access-to-object type is illegal unless it is a general access
-- is a general access type that designates a class-wide limited -- type that designates a class-wide limited private type.
-- private type. There are also constraints about the primitive -- Note that constraints on the primitive subprograms of the
-- subprograms of the class-wide type. -- designated tagged type are not enforced here but in
-- Validate_RACW_Primitives, which is done separately because the
-- designated type might not be frozen (and therefore its
-- primitive operations might not be completely known) at the
-- point of the RACW declaration.
Validate_Remote_Access_Object_Type_Declaration (T); Validate_Remote_Access_Object_Type_Declaration (T);
...@@ -810,7 +864,6 @@ package body Sem_Cat is ...@@ -810,7 +864,6 @@ package body Sem_Cat is
loop loop
U := Scope (U); U := Scope (U);
end loop; end loop;
end if; end if;
if Nkind (P) /= N_Compilation_Unit then if Nkind (P) /= N_Compilation_Unit then
...@@ -834,7 +887,6 @@ package body Sem_Cat is ...@@ -834,7 +887,6 @@ package body Sem_Cat is
begin begin
Item := First (Context_Items (P)); Item := First (Context_Items (P));
while Present (Item) loop while Present (Item) loop
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then not (Implicit_With (Item) and then not (Implicit_With (Item)
...@@ -883,6 +935,13 @@ package body Sem_Cat is ...@@ -883,6 +935,13 @@ package body Sem_Cat is
procedure Validate_Controlled_Object (E : Entity_Id) is procedure Validate_Controlled_Object (E : Entity_Id) is
begin begin
-- Don't need this check in Ada 2005 mode, where this is all taken
-- care of by the mechanism for Preelaborable Initialization.
if Ada_Version >= Ada_05 then
return;
end if;
-- For now, never apply this check for internal GNAT units, since we -- For now, never apply this check for internal GNAT units, since we
-- have a number of cases in the library where we are stuck with objects -- have a number of cases in the library where we are stuck with objects
-- of this type, and the RM requires Preelaborate. -- of this type, and the RM requires Preelaborate.
...@@ -920,7 +979,6 @@ package body Sem_Cat is ...@@ -920,7 +979,6 @@ package body Sem_Cat is
begin begin
if In_Preelaborated_Unit then if In_Preelaborated_Unit then
Item := First (Statements (Handled_Statement_Sequence (N))); Item := First (Statements (Handled_Statement_Sequence (N)));
while Present (Item) loop while Present (Item) loop
if Nkind (Item) /= N_Label if Nkind (Item) /= N_Label
and then Nkind (Item) /= N_Null_Statement and then Nkind (Item) /= N_Null_Statement
...@@ -1003,9 +1061,10 @@ package body Sem_Cat is ...@@ -1003,9 +1061,10 @@ package body Sem_Cat is
if Is_Array_Type (Ent) then if Is_Array_Type (Ent) then
declare declare
Comp_Type : Entity_Id := Component_Type (Ent); Comp_Type : Entity_Id;
begin begin
Comp_Type := Component_Type (Ent);
while Is_Array_Type (Comp_Type) loop while Is_Array_Type (Comp_Type) loop
Comp_Type := Component_Type (Comp_Type); Comp_Type := Component_Type (Comp_Type);
end loop; end loop;
...@@ -1032,21 +1091,64 @@ package body Sem_Cat is ...@@ -1032,21 +1091,64 @@ package body Sem_Cat is
end if; end if;
end if; end if;
-- We relax the restriction of 10.2.1(9) within GNAT -- Check for invalid use of private object. Note that Ada 2005
-- units. (There are ACVC tests that check that the -- AI-161 modifies the rules for Ada 2005, including the use of
-- restriction is enforced, but note that AI-161, -- the new pragma Preelaborable_Initialization.
-- once approved, will relax the restriction prohibiting
-- default-initialized objects of private types, and if Is_Private_Type (Ent)
-- will recommend a pragma for marking private types.) or else Depends_On_Private (Ent)
if (Is_Private_Type (Ent)
or else Depends_On_Private (Ent))
and then not Is_Internal_File_Name
(Unit_File_Name (Get_Source_Unit (N)))
then then
-- Case where type has preelaborable initialization which
-- means that a pragma Preelaborable_Initialization was
-- given for the private type.
if Has_Preelaborable_Initialization (Ent) then
-- But for the predefined units, we will ignore this
-- status unless we are in Ada 2005 mode since we want
-- Ada 95 compatible behavior, in which the entities
-- marked with this pragma in the predefined library are
-- not treated specially.
if Ada_Version < Ada_05 then
Error_Msg_N Error_Msg_N
("private object not allowed in preelaborated unit", N); ("private object not allowed in preelaborated unit",
return; N);
Error_Msg_N ("\(would be legal in Ada 2005 mode)", N);
end if;
-- Type does not have preelaborable initialization
else
-- We allow this when compiling in GNAT mode to make life
-- easier for some cases where it would otherwise be hard
-- to be exactly valid Ada.
if not GNAT_Mode then
Error_Msg_N
("private object not allowed in preelaborated unit",
N);
-- If we are in Ada 2005 mode, add a message if pragma
-- Preelaborable_Initialization on the type of the
-- object would help.
-- If the type has no full view (generic type, or
-- previous error), the warning does not apply.
if Ada_Version >= Ada_05
and then Is_Private_Type (Ent)
and then Present (Full_View (Ent))
and then
Has_Preelaborable_Initialization (Full_View (Ent))
then
Error_Msg_Sloc := Sloc (Ent);
Error_Msg_NE
("\would be legal if pragma Preelaborable_" &
"Initialization given for & #", N, Ent);
end if;
end if;
end if;
-- Access to Task or Protected type -- Access to Task or Protected type
...@@ -1109,9 +1211,9 @@ package body Sem_Cat is ...@@ -1109,9 +1211,9 @@ package body Sem_Cat is
end if; end if;
end if; end if;
-- A pure library_item must not contain the declaration of any -- A pure library_item must not contain the declaration of any variable
-- variable except within a subprogram, generic subprogram, task -- except within a subprogram, generic subprogram, task unit, or
-- unit or protected unit (RM 10.2.1(16)). -- protected unit (RM 10.2.1(16)).
if In_Pure_Unit if In_Pure_Unit
and then not In_Subprogram_Task_Protected_Unit and then not In_Subprogram_Task_Protected_Unit
...@@ -1134,6 +1236,113 @@ package body Sem_Cat is ...@@ -1134,6 +1236,113 @@ package body Sem_Cat is
end Validate_Object_Declaration; end Validate_Object_Declaration;
------------------------------
-- Validate_RACW_Primitives --
------------------------------
procedure Validate_RACW_Primitives (T : Entity_Id) is
Desig_Type : Entity_Id;
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;
begin
Desig_Type := Etype (Designated_Type (T));
Primitive_Subprograms := Primitive_Operations (Desig_Type);
Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
while Subprogram_Elmt /= No_Elmt loop
Subprogram := Node (Subprogram_Elmt);
if not Comes_From_Source (Subprogram) then
goto Next_Subprogram;
end if;
-- Check return type
if Ekind (Subprogram) = E_Function then
Rtyp := Etype (Subprogram);
if Has_Controlling_Result (Subprogram) then
null;
elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
Error_Msg_N
("anonymous access result in remote object primitive", 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
("limited return type must have Read and Write attributes",
Parent (Subprogram));
Explain_Limited_Type (Rtyp, Parent (Subprogram));
end if;
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
-- Now find out if this parameter is a controlling parameter
Param := Defining_Identifier (Param_Spec);
Param_Type := Etype (Param);
if Is_Controlling_Formal (Param) then
-- It is a controlling parameter, so specific checks below
-- do not apply.
null;
elsif Ekind (Param_Type) = E_Anonymous_Access_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);
elsif Is_Limited_Type (Param_Type) then
-- Not a controlling parameter, so type must have Read and
-- Write attributes.
if No (TSS (Param_Type, TSS_Stream_Read))
or else
No (TSS (Param_Type, TSS_Stream_Write))
then
Error_Msg_N
("limited formal must have Read and Write attributes",
Param_Spec);
Explain_Limited_Type (Param_Type, Param_Spec);
end if;
end if;
-- Check next parameter in this subprogram
Next (Param_Spec);
end loop;
<<Next_Subprogram>>
Next_Elmt (Subprogram_Elmt);
end loop;
end Validate_RACW_Primitives;
------------------------------- -------------------------------
-- Validate_RCI_Declarations -- -- Validate_RCI_Declarations --
------------------------------- -------------------------------
...@@ -1147,7 +1356,7 @@ package body Sem_Cat is ...@@ -1147,7 +1356,7 @@ package body Sem_Cat is
if Comes_From_Source (E) then if Comes_From_Source (E) then
if Is_Limited_Type (E) then if Is_Limited_Type (E) then
Error_Msg_N Error_Msg_N
("Limited type not allowed in rci unit", Parent (E)); ("limited type not allowed in rci unit", Parent (E));
Explain_Limited_Type (E, Parent (E)); Explain_Limited_Type (E, Parent (E));
elsif Ekind (E) = E_Generic_Function elsif Ekind (E) = E_Generic_Function
...@@ -1164,10 +1373,10 @@ package body Sem_Cat is ...@@ -1164,10 +1373,10 @@ package body Sem_Cat is
Error_Msg_N Error_Msg_N
("inlined subprogram not allowed in rci unit", Parent (E)); ("inlined subprogram not allowed in rci unit", Parent (E));
-- Inner packages that are renamings need not be checked. -- Inner packages that are renamings need not be checked. Generic
-- Generic RCI packages are subject to the checks, but -- RCI packages are subject to the checks, but entities that come
-- entities that come from formal packages are not part of the -- from formal packages are not part of the visible declarations
-- visible declarations of the package and are not checked. -- of the package and are not checked.
elsif Ekind (E) = E_Package then elsif Ekind (E) = E_Package then
if Present (Renamed_Entity (E)) then if Present (Renamed_Entity (E)) then
...@@ -1235,7 +1444,6 @@ package body Sem_Cat is ...@@ -1235,7 +1444,6 @@ package body Sem_Cat is
if Present (Profile) then if Present (Profile) then
Param_Spec := First (Profile); Param_Spec := First (Profile);
while Present (Param_Spec) loop while Present (Param_Spec) loop
Param_Type := Etype (Defining_Identifier (Param_Spec)); Param_Type := Etype (Defining_Identifier (Param_Spec));
Type_Decl := Parent (Param_Type); Type_Decl := Parent (Param_Type);
...@@ -1256,10 +1464,9 @@ package body Sem_Cat is ...@@ -1256,10 +1464,9 @@ package body Sem_Cat is
Error_Node); Error_Node);
end if; end if;
-- For limited private type parameter, we check only the -- For limited private type parameter, we check only the private
-- private declaration and ignore full type declaration, -- declaration and ignore full type declaration, unless this is
-- unless this is the only declaration for the type, eg. -- the only declaration for the type, eg. as a limited record.
-- as a limited record.
elsif Is_Limited_Type (Param_Type) elsif Is_Limited_Type (Param_Type)
and then (Nkind (Type_Decl) = N_Private_Type_Declaration and then (Nkind (Type_Decl) = N_Private_Type_Declaration
...@@ -1347,16 +1554,10 @@ package body Sem_Cat is ...@@ -1347,16 +1554,10 @@ package body Sem_Cat is
procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
Direct_Designated_Type : Entity_Id; Direct_Designated_Type : Entity_Id;
Desig_Type : Entity_Id; Desig_Type : Entity_Id;
Primitive_Subprograms : Elist_Id;
Subprogram : Elmt_Id;
Subprogram_Node : Node_Id;
Profile : List_Id;
Param_Spec : Node_Id;
Param_Type : Entity_Id;
begin begin
-- We are called from Analyze_Type_Declaration, and the Nkind -- We are called from Analyze_Type_Declaration, and the Nkind of the
-- of the given node is N_Access_To_Object_Definition. -- given node is N_Access_To_Object_Definition.
if not Comes_From_Source (T) if not Comes_From_Source (T)
or else (not In_RCI_Declaration (Parent (T)) or else (not In_RCI_Declaration (Parent (T))
...@@ -1373,24 +1574,24 @@ package body Sem_Cat is ...@@ -1373,24 +1574,24 @@ package body Sem_Cat is
return; return;
end if; end if;
-- Check RCI or RT unit type declaration. It may not contain -- Check RCI or RT unit type declaration. It may not contain the
-- the declaration of an access-to-object type unless it is a -- declaration of an access-to-object type unless it is a general access
-- general access type that designates a class-wide limited -- type that designates a class-wide limited private type. There are
-- private type. There are also constraints about the primitive -- also constraints on the primitive subprograms of the class-wide type
-- subprograms of the class-wide type (RM E.2.3(14)). -- (RM E.2.2(14), see Validate_RACW_Primitives).
if Ekind (T) /= E_General_Access_Type if Ekind (T) /= E_General_Access_Type
or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type
then then
if In_RCI_Declaration (Parent (T)) then if In_RCI_Declaration (Parent (T)) then
Error_Msg_N Error_Msg_N
("access type in Remote_Call_Interface unit must be " & ("error in access type in Remote_Call_Interface unit", T);
"general access", T);
else else
Error_Msg_N ("access type in Remote_Types unit must be " & Error_Msg_N
"general access", T); ("error in access type in Remote_Types unit", T);
end if; end if;
Error_Msg_N ("\to class-wide type", T);
Error_Msg_N ("\must be general access to class-wide type", T);
return; return;
end if; end if;
...@@ -1405,80 +1606,6 @@ package body Sem_Cat is ...@@ -1405,80 +1606,6 @@ package body Sem_Cat is
return; return;
end if; end if;
Primitive_Subprograms := Primitive_Operations (Desig_Type);
Subprogram := First_Elmt (Primitive_Subprograms);
while Subprogram /= No_Elmt loop
Subprogram_Node := Node (Subprogram);
if not Comes_From_Source (Subprogram_Node) then
goto Next_Subprogram;
end if;
Profile := Parameter_Specifications (Parent (Subprogram_Node));
-- Profile must exist, otherwise not primitive operation
Param_Spec := First (Profile);
while Present (Param_Spec) loop
-- Now find out if this parameter is a controlling parameter
Param_Type := Parameter_Type (Param_Spec);
if (Nkind (Param_Type) = N_Access_Definition
and then Etype (Subtype_Mark (Param_Type)) = Desig_Type)
or else (Nkind (Param_Type) /= N_Access_Definition
and then Etype (Param_Type) = Desig_Type)
then
-- It is a controlling parameter, so specific checks below
-- do not apply.
null;
elsif
Nkind (Param_Type) = N_Access_Definition
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);
elsif
Is_Limited_Type (Etype (Defining_Identifier (Param_Spec)))
then
-- Not a controlling parameter, so type must have Read
-- and Write attributes.
if Nkind (Param_Type) in N_Has_Etype
and then Nkind (Parent (Etype (Param_Type))) =
N_Private_Type_Declaration
then
Param_Type := Etype (Param_Type);
if No (TSS (Param_Type, TSS_Stream_Read))
or else
No (TSS (Param_Type, TSS_Stream_Write))
then
Error_Msg_N
("limited formal must have Read and Write attributes",
Param_Spec);
Explain_Limited_Type
(Etype (Defining_Identifier (Param_Spec)), Param_Spec);
end if;
end if;
end if;
-- Check next parameter in this subprogram
Next (Param_Spec);
end loop;
<<Next_Subprogram>>
Next_Elmt (Subprogram);
end loop;
-- Now this is an RCI unit access-to-class-wide-limited-private type -- Now this is an RCI unit access-to-class-wide-limited-private type
-- declaration. Set the type entity to be Is_Remote_Call_Interface to -- declaration. Set the type entity to be Is_Remote_Call_Interface to
-- optimize later checks by avoiding tree traversal to find out if this -- optimize later checks by avoiding tree traversal to find out if this
...@@ -1545,8 +1672,8 @@ package body Sem_Cat is ...@@ -1545,8 +1672,8 @@ package body Sem_Cat is
end if; end if;
-- This subprogram also enforces the checks in E.2.2(13). A value of -- This subprogram also enforces the checks in E.2.2(13). A value of
-- such type must not be dereferenced unless as controlling operand of a -- such type must not be dereferenced unless as controlling operand of
-- dispatching call. -- a dispatching call.
elsif K = N_Explicit_Dereference elsif K = N_Explicit_Dereference
and then (Comes_From_Source (N) and then (Comes_From_Source (N)
...@@ -1565,8 +1692,7 @@ package body Sem_Cat is ...@@ -1565,8 +1692,7 @@ package body Sem_Cat is
-- If we have a true dereference that comes from source and that -- If we have a true dereference that comes from source and that
-- is a controlling argument for a dispatching call, accept it. -- is a controlling argument for a dispatching call, accept it.
if K = N_Explicit_Dereference if Is_Actual_Parameter (N)
and then Is_Actual_Parameter (N)
and then Is_Controlling_Actual (N) and then Is_Controlling_Actual (N)
then then
return; return;
...@@ -1582,17 +1708,12 @@ package body Sem_Cat is ...@@ -1582,17 +1708,12 @@ package body Sem_Cat is
return; return;
end if; end if;
-- The following is to let the compiler generated tags check pass -- We must allow expanded code to generate a reference to the tag of
-- through without error message. This is a bit kludgy isn't there -- the designated object (may be either the actual tag, or the stub
-- some better way of making this exclusion ??? -- tag in the case of a remote object).
if (PK = N_Selected_Component if PK = N_Selected_Component
and then Present (Parent (Parent (N))) and then Is_Tag (Entity (Selector_Name (Parent (N))))
and then Nkind (Parent (Parent (N))) = N_Op_Ne)
or else (PK = N_Unchecked_Type_Conversion
and then Present (Parent (Parent (N)))
and then
Nkind (Parent (Parent (N))) = N_Selected_Component)
then then
return; return;
end if; end if;
...@@ -1673,8 +1794,8 @@ package body Sem_Cat is ...@@ -1673,8 +1794,8 @@ package body Sem_Cat is
Spec : constant Node_Id := Specification (N); Spec : constant Node_Id := Specification (N);
Name_U : constant Entity_Id := Defining_Entity (Spec); Name_U : constant Entity_Id := Defining_Entity (Spec);
Typ : Entity_Id; Typ : Entity_Id;
U_Typ : Entity_Id;
First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U); First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
In_Visible_Part : Boolean := True;
begin begin
if not Is_Remote_Types (Name_U) then if not Is_Remote_Types (Name_U) then
...@@ -1682,27 +1803,31 @@ package body Sem_Cat is ...@@ -1682,27 +1803,31 @@ package body Sem_Cat is
end if; end if;
Typ := First_Entity (Name_U); Typ := First_Entity (Name_U);
while Present (Typ) loop while Present (Typ) and then Typ /= First_Priv_Ent loop
if In_Visible_Part and then Typ = First_Priv_Ent then U_Typ := Underlying_Type (Typ);
In_Visible_Part := False;
if No (U_Typ) then
U_Typ := Typ;
end if; end if;
if Comes_From_Source (Typ) if Comes_From_Source (Typ) and then Is_Type (Typ) then
and then Is_Type (Typ)
and then (In_Visible_Part or else Has_Private_Declaration (Typ))
then
if Missing_Read_Write_Attributes (Typ) then if Missing_Read_Write_Attributes (Typ) then
if Is_Non_Remote_Access_Type (Typ) then if Is_Non_Remote_Access_Type (Typ) then
Error_Msg_N Error_Msg_N ("error in non-remote access type", U_Typ);
("non-remote access type without user-defined Read " &
"and Write attributes", Typ);
else else
Error_Msg_N Error_Msg_N
("record type containing a component of a " & ("error in record type containing a component of a " &
"non-remote access", Typ); "non-remote access type", U_Typ);
end if;
if Ada_Version >= Ada_05 then
Error_Msg_N Error_Msg_N
("\type without Read and Write attributes " & ("\must have visible Read and Write attribute " &
"('R'M E.2.2(8))", Typ); "definition clauses ('R'M E.2.2(8))", U_Typ);
else
Error_Msg_N
("\must have Read and Write attribute " &
"definition clauses ('R'M E.2.2(8))", U_Typ);
end if; end if;
end if; end if;
end if; end if;
...@@ -1791,6 +1916,9 @@ package body Sem_Cat is ...@@ -1791,6 +1916,9 @@ package body Sem_Cat is
function Is_Primary (N : Node_Id) return Boolean; function Is_Primary (N : Node_Id) return Boolean;
-- Determine whether node is syntactically a primary in an expression -- Determine whether node is syntactically a primary in an expression
-- This function should probably be somewhere else ???
-- Also it does not do what it says, e.g if N is a binary operator
-- whose parent is a binary operator, Is_Primary returns True ???
---------------- ----------------
-- Is_Primary -- -- Is_Primary --
...@@ -1801,7 +1929,7 @@ package body Sem_Cat is ...@@ -1801,7 +1929,7 @@ package body Sem_Cat is
begin begin
case K is case K is
when N_Op | N_In | N_Not_In => when N_Op | N_Membership_Test =>
return True; return True;
when N_Aggregate when N_Aggregate
...@@ -1874,7 +2002,9 @@ package body Sem_Cat is ...@@ -1874,7 +2002,9 @@ package body Sem_Cat is
and then (not Inside_A_Generic and then (not Inside_A_Generic
or else Present (Enclosing_Generic_Body (N))) or else Present (Enclosing_Generic_Body (N)))
then then
if Ekind (Entity (N)) = E_Variable then if Ekind (Entity (N)) = E_Variable
or else Ekind (Entity (N)) in Formal_Object_Kind
then
Flag_Non_Static_Expr Flag_Non_Static_Expr
("non-static object name in preelaborated unit", N); ("non-static object name in preelaborated unit", N);
...@@ -1918,7 +2048,6 @@ package body Sem_Cat is ...@@ -1918,7 +2048,6 @@ package body Sem_Cat is
Flag_Non_Static_Expr Flag_Non_Static_Expr
("non-static constant in preelaborated unit", N); ("non-static constant in preelaborated unit", N);
end if; end if;
end if; end if;
end if; end if;
end if; end if;
......
gcc/ada/sem_cat.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006, 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- --
...@@ -36,10 +36,21 @@ ...@@ -36,10 +36,21 @@
-- Note that we treat Preelaborate as a categorization pragma, even though -- Note that we treat Preelaborate as a categorization pragma, even though
-- strictly, according to RM E.2(2,3), the term does not apply in this case. -- strictly, according to RM E.2(2,3), the term does not apply in this case.
with Exp_Tss; use Exp_Tss;
with Types; use Types; with Types; use Types;
package Sem_Cat is package Sem_Cat is
function Has_Stream_Attribute_Definition
(Typ : Entity_Id; Nam : TSS_Name_Type) return Boolean;
-- True when there is a attribute definition clause specifying attribute
-- Nam for Typ. In Ada 2005 mode, returns True only when the attribute
-- definition clause is visible. Note that attribute definition clauses
-- inherited from parent types are taken into account by this predicate
-- (to test for presence of an attribute definition clause for one
-- specific type, excluding inherited definitions, the flags
-- Has_Specicied_Stream_* can be used instead).
function In_Preelaborated_Unit return Boolean; function In_Preelaborated_Unit return Boolean;
-- Determines if the current scope is within a preelaborated compilation -- Determines if the current scope is within a preelaborated compilation
-- unit, that is one to which one of the pragmas Preelaborate, Pure, -- unit, that is one to which one of the pragmas Preelaborate, Pure,
...@@ -137,4 +148,10 @@ package Sem_Cat is ...@@ -137,4 +148,10 @@ package Sem_Cat is
-- are not included because the generic declaration and body are -- are not included because the generic declaration and body are
-- preelaborable. -- preelaborable.
procedure Validate_RACW_Primitives (T : Entity_Id);
-- Enforce constraints on primitive operations of the designated type of
-- an RACW. Note that since the complete set of primitive operations of the
-- designated type needs to be known, we must defer these checks until the
-- desgianted type is frozen.
end Sem_Cat; end Sem_Cat;
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