with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat;
+with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
-- the type of the prefix. If prefix is overloaded, so it the
-- 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 --
------------------------------
end if;
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
begin
P);
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_Access_Subprogram_Type (P);
end if;
-- 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
Typ := Entity (P);
elsif Is_Task_Type (Typ) then
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
else
procedure Check_Enum_Image is
Lit : Entity_Id;
-
begin
if Is_Enumeration_Type (P_Base_Type) then
Lit := First_Literal (P_Base_Type);
procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id;
Btyp : Entity_Id;
+
begin
Validate_Non_Static_Attribute_Function_Call;
return False;
end On_X86;
+ -- Start of processing for Alignment_Kludge
+
begin
if Aname = Name_Maximum_Alignment and then On_X86 then
P := Parent (N);
elsif Entity (P) = Current_Scope
and then Is_Record_Type (Entity (P))
then
-
-- Use of current instance within the type. Verify that if the
-- attribute appears within a constraint, it yields an access
-- type, other uses are illegal.
begin
Get_First_Interp (P, I, It);
-
while Present (It.Nam) loop
if Comes_From_Source (It.Nam) then
Count := Count + 1;
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
-- analyze and resolve the type conversion to generate the code
-- 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));
+ else
+ Analyze (N);
end if;
-- Otherwise we just need to find the proper type
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 --
-----------
if Is_Access_Type (P_Type) then
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
if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
------------------
when Attribute_Storage_Size =>
-
if Is_Task_Type (P_Type) then
Check_E0;
Set_Etype (N, Universal_Integer);
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)
and then Is_Type (Entity (P))
then
Error_Attr ("invalid prefix for % attribute", P);
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 --
----------
Attribute_Partition_ID |
Attribute_Pool_Address |
Attribute_Position |
+ Attribute_Priority |
Attribute_Read |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
+ Attribute_Stub_Type |
Attribute_Tag |
Attribute_Target_Name |
Attribute_Terminated |
Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
Btyp : constant Entity_Id := Base_Type (Typ);
+ Des_Btyp : Entity_Id;
Index : Interp_Index;
It : Interp;
Nom_Subt : Entity_Id;
-- X'Access is illegal if X denotes a constant and the access
-- type is access-to-variable. Same for 'Unchecked_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
or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
or else Is_Variable (P)
or else Attr_Id = Attribute_Unrestricted_Access)
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);
end if;
end if;
-- enclosing composite type.
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 Attr_Id = Attribute_Access
then
-- In an instance, this is a runtime check, but one we
-- know will fail, so generate an appropriate warning.
Nom_Subt := Etype (Nom_Subt);
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 the attribute is in the context of an access
(N, Etype (Designated_Type (Typ)));
end if;
- elsif not Subtypes_Statically_Match
- (Designated_Type (Base_Type (Typ)), Nom_Subt)
+ -- Ada 2005 (AI-363): Require static matching when designated
+ -- 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
not (Has_Discriminants (Designated_Type (Typ))
+ and then not Is_Constrained (Des_Btyp)
and then
- not Is_Constrained
- (Designated_Type (Base_Type (Typ))))
+ (Ada_Version < Ada_05
+ or else
+ not Has_Constrained_Partial_View
+ (Designated_Type (Base_Type (Typ)))))
then
Error_Msg_N
("object subtype must statically match "
if Is_Entity_Name (P)
and then Is_Array_Type (Designated_Type (Typ))
then
-
declare
D : constant Node_Id := Declaration_Node (Entity (P));
is
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
begin
-- 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;
end if;
while Etype (Etyp) /= Etyp loop
Etyp := Etype (Etyp);
- if Has_Specified_Stream_Attribute (Etyp, Nam) then
+ if Has_Stream_Attribute_Definition (Etyp, Nam) then
return True;
end if;
end loop;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Lib; use Lib;
with Nlists; use Nlists;
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean;
-- Return True if the entity or one of its subcomponent is an access
-- 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;
-- Determines if a declaration is within the visible part of a Remote
-- for semantic checking purposes.
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;
-- Determines if current scope is within a Shared Passive compilation unit
end loop;
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 --
---------------------------
begin
-- There are no constraints on body of remote_call_interface or
- -- remote_types packages..
+ -- remote_types packages.
return (Unit_Entity /= Standard_Standard)
and then (Is_Preelaborated (Unit_Entity)
-------------------------------
function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is
+ U_E : constant Entity_Id := Underlying_Type (E);
begin
- return Is_Access_Type (E)
- and then not Is_Remote_Access_To_Class_Wide_Type (E)
- and then not Is_Remote_Access_To_Subprogram_Type (E);
+ if No (U_E) then
+
+ -- 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;
------------------------------------
function Missing_Read_Write_Attributes (E : Entity_Id) return Boolean is
Component : Entity_Id;
Component_Type : Entity_Id;
+ U_E : constant Entity_Id := Underlying_Type (E);
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 --
-------------------------------
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
- -- We start from the declaration node and then loop until the end
- -- of the list until we find those two attribute definition clauses.
-
- 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;
+ return True
+ and then Has_Stream_Attribute_Definition (E, TSS_Stream_Read)
+ and then Has_Stream_Attribute_Definition (E, TSS_Stream_Write);
end Has_Read_Write_Attributes;
-- Start of processing for Missing_Read_Write_Attributes
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;
- elsif Is_Non_Remote_Access_Type (E) then
+
+ elsif Is_Non_Remote_Access_Type (U_E) then
return True;
end if;
- if Is_Record_Type (E) then
- Component := First_Entity (E);
+ if Is_Record_Type (U_E) then
+ Component := First_Entity (U_E);
while Present (Component) loop
- Component_Type := Etype (Component);
+ if not Is_Tag (Component) then
+ Component_Type := Etype (Component);
- if (Is_Non_Remote_Access_Type (Component_Type)
- or else Is_Record_Type (Component_Type))
- and then Missing_Read_Write_Attributes (Component_Type)
- then
- return True;
+ if Missing_Read_Write_Attributes (Component_Type) then
+ return True;
+ end if;
end if;
Next_Entity (Component);
-- the argument of the pragma can be resolved properly, and reset
-- afterwards.
- procedure Set_Parents (Visibility : Boolean) is
- Par : Entity_Id := Scope (S);
+ -----------------
+ -- Set_Parents --
+ -----------------
+ procedure Set_Parents (Visibility : Boolean) is
+ Par : Entity_Id;
begin
+ Par := Scope (S);
while Present (Par) and then Par /= Standard_Standard loop
Set_Is_Immediately_Visible (Par, Visibility);
Par := Scope (Par);
end loop;
end Set_Parents;
+ -- Start of processing for Set_Categorization_From_Pragmas
+
begin
-- Deal with categorization pragmas in Pragmas of Compilation_Unit.
-- The purpose is to set categorization flags before analyzing the
end if;
declare
- PN : Node_Id := First (Pragmas_After (Aux_Decls_Node (P)));
+ PN : Node_Id;
begin
-
if Is_Child_Unit (S)
and then Is_Generic_Instance (S)
then
Set_Parents (True);
end if;
+ PN := First (Pragmas_After (Aux_Decls_Node (P)));
while Present (PN) loop
-- Skip implicit types that may have been introduced by
Next (PN);
end loop;
+
if Is_Child_Unit (S)
and then Is_Generic_Instance (S)
then
Set_Parents (False);
end if;
-
end;
end Set_Categorization_From_Pragmas;
Set_Is_Pure_Unit_Access_Type (T);
end if;
- -- Check for RCI or RT unit type declaration. It should not
- -- contain the declaration of an access-to-object type unless it
- -- is a general access type that designates a class-wide limited
- -- private type. There are also constraints about the primitive
- -- subprograms of the class-wide type.
+ -- Check for RCI or RT unit type declaration: declaration of an
+ -- access-to-object type is illegal unless it is a general access
+ -- type that designates a class-wide limited private type.
+ -- Note that constraints on the primitive subprograms of the
+ -- 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);
loop
U := Scope (U);
end loop;
-
end if;
if Nkind (P) /= N_Compilation_Unit then
begin
Item := First (Context_Items (P));
-
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not (Implicit_With (Item)
procedure Validate_Controlled_Object (E : Entity_Id) is
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
-- have a number of cases in the library where we are stuck with objects
-- of this type, and the RM requires Preelaborate.
begin
if In_Preelaborated_Unit then
Item := First (Statements (Handled_Statement_Sequence (N)));
-
while Present (Item) loop
if Nkind (Item) /= N_Label
and then Nkind (Item) /= N_Null_Statement
if Is_Array_Type (Ent) then
declare
- Comp_Type : Entity_Id := Component_Type (Ent);
+ Comp_Type : Entity_Id;
begin
+ Comp_Type := Component_Type (Ent);
while Is_Array_Type (Comp_Type) loop
Comp_Type := Component_Type (Comp_Type);
end loop;
end if;
end if;
- -- We relax the restriction of 10.2.1(9) within GNAT
- -- units. (There are ACVC tests that check that the
- -- restriction is enforced, but note that AI-161,
- -- once approved, will relax the restriction prohibiting
- -- default-initialized objects of private types, and
- -- will recommend a pragma for marking private types.)
-
- 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)))
+ -- Check for invalid use of private object. Note that Ada 2005
+ -- AI-161 modifies the rules for Ada 2005, including the use of
+ -- the new pragma Preelaborable_Initialization.
+
+ if Is_Private_Type (Ent)
+ or else Depends_On_Private (Ent)
then
- Error_Msg_N
- ("private object not allowed in preelaborated unit", N);
- return;
+ -- 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
+ ("private object not allowed in preelaborated unit",
+ 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
end if;
end if;
- -- A pure library_item must not contain the declaration of any
- -- variable except within a subprogram, generic subprogram, task
- -- unit or protected unit (RM 10.2.1(16)).
+ -- A pure library_item must not contain the declaration of any variable
+ -- except within a subprogram, generic subprogram, task unit, or
+ -- protected unit (RM 10.2.1(16)).
if In_Pure_Unit
and then not In_Subprogram_Task_Protected_Unit
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 --
-------------------------------
if Comes_From_Source (E) then
if Is_Limited_Type (E) then
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));
elsif Ekind (E) = E_Generic_Function
Error_Msg_N
("inlined subprogram not allowed in rci unit", Parent (E));
- -- Inner packages that are renamings need not be checked.
- -- Generic RCI packages are subject to the checks, but
- -- entities that come from formal packages are not part of the
- -- visible declarations of the package and are not checked.
+ -- Inner packages that are renamings need not be checked. Generic
+ -- RCI packages are subject to the checks, but entities that come
+ -- from formal packages are not part of the visible declarations
+ -- of the package and are not checked.
elsif Ekind (E) = E_Package then
if Present (Renamed_Entity (E)) then
if Present (Profile) then
Param_Spec := First (Profile);
-
while Present (Param_Spec) loop
Param_Type := Etype (Defining_Identifier (Param_Spec));
Type_Decl := Parent (Param_Type);
Error_Node);
end if;
- -- For limited private type parameter, we check only the
- -- private declaration and ignore full type declaration,
- -- unless this is the only declaration for the type, eg.
- -- as a limited record.
+ -- For limited private type parameter, we check only the private
+ -- declaration and ignore full type declaration, unless this is
+ -- the only declaration for the type, eg. as a limited record.
elsif Is_Limited_Type (Param_Type)
and then (Nkind (Type_Decl) = N_Private_Type_Declaration
procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
Direct_Designated_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
- -- We are called from Analyze_Type_Declaration, and the Nkind
- -- of the given node is N_Access_To_Object_Definition.
+ -- We are called from Analyze_Type_Declaration, and the Nkind of the
+ -- given node is N_Access_To_Object_Definition.
if not Comes_From_Source (T)
or else (not In_RCI_Declaration (Parent (T))
return;
end if;
- -- Check RCI or RT unit type declaration. It may not contain
- -- the declaration of an access-to-object type unless it is a
- -- general access type that designates a class-wide limited
- -- private type. There are also constraints about the primitive
- -- subprograms of the class-wide type (RM E.2.3(14)).
+ -- Check RCI or RT unit type declaration. It may not contain the
+ -- declaration of an access-to-object type unless it is a general access
+ -- type that designates a class-wide limited private type. There are
+ -- also constraints on the primitive subprograms of the class-wide type
+ -- (RM E.2.2(14), see Validate_RACW_Primitives).
if Ekind (T) /= E_General_Access_Type
or else Ekind (Designated_Type (T)) /= E_Class_Wide_Type
then
if In_RCI_Declaration (Parent (T)) then
Error_Msg_N
- ("access type in Remote_Call_Interface unit must be " &
- "general access", T);
+ ("error in access type in Remote_Call_Interface unit", T);
else
- Error_Msg_N ("access type in Remote_Types unit must be " &
- "general access", T);
+ Error_Msg_N
+ ("error in access type in Remote_Types unit", T);
end if;
- Error_Msg_N ("\to class-wide type", T);
+
+ Error_Msg_N ("\must be general access to class-wide type", T);
return;
end if;
return;
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
-- declaration. Set the type entity to be Is_Remote_Call_Interface to
-- optimize later checks by avoiding tree traversal to find out if this
end if;
-- 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
- -- dispatching call.
+ -- such type must not be dereferenced unless as controlling operand of
+ -- a dispatching call.
elsif K = N_Explicit_Dereference
and then (Comes_From_Source (N)
-- If we have a true dereference that comes from source and that
-- is a controlling argument for a dispatching call, accept it.
- if K = N_Explicit_Dereference
- and then Is_Actual_Parameter (N)
+ if Is_Actual_Parameter (N)
and then Is_Controlling_Actual (N)
then
return;
return;
end if;
- -- The following is to let the compiler generated tags check pass
- -- through without error message. This is a bit kludgy isn't there
- -- some better way of making this exclusion ???
-
- if (PK = N_Selected_Component
- and then Present (Parent (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)
+ -- We must allow expanded code to generate a reference to the tag of
+ -- the designated object (may be either the actual tag, or the stub
+ -- tag in the case of a remote object).
+
+ if PK = N_Selected_Component
+ and then Is_Tag (Entity (Selector_Name (Parent (N))))
then
return;
end if;
-------------------------------
procedure Validate_RT_RAT_Component (N : Node_Id) is
- Spec : constant Node_Id := Specification (N);
- Name_U : constant Entity_Id := Defining_Entity (Spec);
- Typ : Entity_Id;
- First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
- In_Visible_Part : Boolean := True;
+ Spec : constant Node_Id := Specification (N);
+ Name_U : constant Entity_Id := Defining_Entity (Spec);
+ Typ : Entity_Id;
+ U_Typ : Entity_Id;
+ First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
begin
if not Is_Remote_Types (Name_U) then
end if;
Typ := First_Entity (Name_U);
- while Present (Typ) loop
- if In_Visible_Part and then Typ = First_Priv_Ent then
- In_Visible_Part := False;
+ while Present (Typ) and then Typ /= First_Priv_Ent loop
+ U_Typ := Underlying_Type (Typ);
+
+ if No (U_Typ) then
+ U_Typ := Typ;
end if;
- if Comes_From_Source (Typ)
- and then Is_Type (Typ)
- and then (In_Visible_Part or else Has_Private_Declaration (Typ))
- then
+ if Comes_From_Source (Typ) and then Is_Type (Typ) then
if Missing_Read_Write_Attributes (Typ) then
if Is_Non_Remote_Access_Type (Typ) then
- Error_Msg_N
- ("non-remote access type without user-defined Read " &
- "and Write attributes", Typ);
+ Error_Msg_N ("error in non-remote access type", U_Typ);
else
Error_Msg_N
- ("record type containing a component of a " &
- "non-remote access", Typ);
+ ("error in record type containing a component of a " &
+ "non-remote access type", U_Typ);
+ end if;
+
+ if Ada_Version >= Ada_05 then
+ Error_Msg_N
+ ("\must have visible Read and Write attribute " &
+ "definition clauses ('R'M E.2.2(8))", U_Typ);
+ else
Error_Msg_N
- ("\type without Read and Write attributes " &
- "('R'M E.2.2(8))", Typ);
+ ("\must have Read and Write attribute " &
+ "definition clauses ('R'M E.2.2(8))", U_Typ);
end if;
end if;
end if;
function Is_Primary (N : Node_Id) return Boolean;
-- 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 --
begin
case K is
- when N_Op | N_In | N_Not_In =>
+ when N_Op | N_Membership_Test =>
return True;
when N_Aggregate
and then (not Inside_A_Generic
or else Present (Enclosing_Generic_Body (N)))
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
("non-static object name in preelaborated unit", N);
Flag_Non_Static_Expr
("non-static constant in preelaborated unit", N);
end if;
-
end if;
end if;
end if;
projects / platform / upstream / linaro-gcc.git / commitdiff