-- --
-- B o d y --
-- --
--- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Check_Overriding_Indicator (Def : Node_Id);
-- Ada 2005 (AI-397): Check the overriding indicator of entries and
- -- subprograms of protected or task types. Def is the definition of
- -- the protected or task type.
+ -- subprograms of protected or task types. Def is the definition of the
+ -- protected or task type.
function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
procedure Install_Declarations (Spec : Entity_Id);
- -- Utility to make visible in corresponding body the entities defined
- -- in task, protected type declaration, or entry declaration.
+ -- Utility to make visible in corresponding body the entities defined in
+ -- task, protected type declaration, or entry declaration.
-----------------------------
-- Analyze_Abort_Statement --
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id;
- -- If the bounds of an entry family depend on task discriminants,
- -- create a new index type where a discriminant is replaced by the
- -- local variable that renames it in the task body.
+ -- If the bounds of an entry family depend on task discriminants, create
+ -- a new index type where a discriminant is replaced by the local
+ -- variable that renames it in the task body.
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
Typ : constant Entity_Id := Entry_Index_Type (E);
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
-
begin
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
return Bound;
-
else
Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
Analyze (Ref);
End_Scope;
end if;
- -- We set the default expressions processed flag because we don't
- -- need default expression functions. This is really more like a
- -- body entity than a spec entity anyway.
+ -- We set the default expressions processed flag because we don't need
+ -- default expression functions. This is really more like body entity
+ -- than a spec entity anyway.
Set_Default_Expressions_Processed (Accept_Id);
Style.Check_Identifier (Nam, Entry_Nam);
end if;
- -- Verify that the entry is not hidden by a procedure declared in
- -- the current block (pathological but possible).
+ -- Verify that the entry is not hidden by a procedure declared in the
+ -- current block (pathological but possible).
if Current_Scope /= Task_Nam then
declare
Error_Msg_N ("invalid entry index in accept for simple entry", N);
end if;
- -- If label declarations present, analyze them. They are declared
- -- in the enclosing task, but their enclosing scope is the entry itself,
- -- so that goto's to the label are recognized as local to the accept.
+ -- If label declarations present, analyze them. They are declared in the
+ -- enclosing task, but their enclosing scope is the entry itself, so
+ -- that goto's to the label are recognized as local to the accept.
if Present (Declarations (N)) then
-
declare
Decl : Node_Id;
Id : Entity_Id;
end;
end if;
- -- If statements are present, they must be analyzed in the context
- -- of the entry, so that references to formals are correctly resolved.
- -- We also have to add the declarations that are required by the
- -- expansion of the accept statement in this case if expansion active.
+ -- If statements are present, they must be analyzed in the context of
+ -- the entry, so that references to formals are correctly resolved. We
+ -- also have to add the declarations that are required by the expansion
+ -- of the accept statement in this case if expansion active.
- -- In the case of a select alternative of a selective accept,
- -- the expander references the address declaration even if there
- -- is no statement list.
+ -- In the case of a select alternative of a selective accept, the
+ -- expander references the address declaration even if there is no
+ -- statement list.
-- We also need to create the renaming declarations for the local
- -- variables that will replace references to the formals within
- -- the accept.
+ -- variables that will replace references to the formals within the
+ -- accept statement.
Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
-- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
-- fields on all entry formals (this loop ignores all other entities).
- -- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that
- -- we can post accurate warnings on each accept statement for the same
+ -- Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that we
+ -- can post accurate warnings on each accept statement for the same
-- entry.
E := First_Entity (Entry_Nam);
Analyze (Trigger);
- -- The trigger is a dispatching procedure. Postpone the analysis
- -- of the triggering and abortable statements until the expansion
- -- of this asynchronous select in Expand_N_Asynchronous_Select.
- -- This action is required since the code replication in Expand-
- -- _N_Asynchronous_Select of an already analyzed statement list
- -- causes Gigi aborts.
+ -- The trigger is a dispatching procedure. Postpone the analysis of
+ -- the triggering and abortable statements until the expansion of
+ -- this asynchronous select in Expand_N_Asynchronous_Select. This
+ -- action is required since otherwise we would get a gigi abort from
+ -- the code replication in Expand_N_Asynchronous_Select of an already
+ -- analyzed statement list.
if Expander_Active
and then Nkind (Trigger) = N_Procedure_Call_Statement
then
Expr := Expression (Delay_Statement (N));
- -- defer full analysis until the statement is expanded, to insure
+ -- Defer full analysis until the statement is expanded, to insure
-- that generated code does not move past the guard. The delay
-- expression is only evaluated if the guard is open.
(Entry_Index_Specification (Formals)));
else
- -- The elaboration of the entry body does not recompute
- -- the bounds of the index, which may have side effects.
- -- Inherit the bounds from the entry declaration. This
- -- is critical if the entry has a per-object constraint.
- -- If a bound is given by a discriminant, it must be
- -- reanalyzed in order to capture the discriminal of the
- -- current entry, rather than that of the protected type.
+ -- The elaboration of the entry body does not recompute the
+ -- bounds of the index, which may have side effects. Inherit
+ -- the bounds from the entry declaration. This is critical
+ -- if the entry has a per-object constraint. If a bound is
+ -- given by a discriminant, it must be reanalyzed in order
+ -- to capture the discriminal of the current entry, rather
+ -- than that of the protected type.
declare
Index_Spec : constant Node_Id :=
Set_Etype (Def, Empty);
Set_Analyzed (Def, False);
- -- Keep the original subtree to ensure tree is
- -- properly formed (e.g. for ASIS use)
+ -- Keep the original subtree to ensure a properly
+ -- formed tree (e.g. for ASIS use).
Rewrite
(Discrete_Subtype_Definition (Index_Spec), Def);
-- formals (see exp_ch9.Add_Formal_Renamings).
declare
- E1 : Entity_Id;
- E2 : Entity_Id;
+ E1 : Entity_Id;
+ E2 : Entity_Id;
begin
E1 := First_Entity (Entry_Name);
Next_Entity (E2);
end loop;
- -- If no matching body entity, then we already had
- -- a detected error of some kind, so just forget
- -- about worrying about these warnings.
+ -- If no matching body entity, then we already had a detected
+ -- error of some kind, so just forget about worrying about these
+ -- warnings.
if No (E2) then
goto Continue;
then
End_Scope;
end if;
-
end Analyze_Entry_Body;
------------------------------------
-- Analyze_Entry_Index_Specification --
---------------------------------------
- -- The defining_Identifier of the entry index specification is local
- -- to the entry body, but must be available in the entry barrier,
- -- which is evaluated outside of the entry body. The index is eventually
- -- renamed as a run-time object, so is visibility is strictly a front-end
- -- concern. In order to make it available to the barrier, we create
- -- an additional scope, as for a loop, whose only declaration is the
- -- index name. This loop is not attached to the tree and does not appear
- -- as an entity local to the protected type, so its existence need only
- -- be knwown to routines that process entry families.
+ -- The Defining_Identifier of the entry index specification is local to the
+ -- entry body, but it must be available in the entry barrier which is
+ -- evaluated outside of the entry body. The index is eventually renamed as
+ -- a run-time object, so is visibility is strictly a front-end concern. In
+ -- order to make it available to the barrier, we create an additional
+ -- scope, as for a loop, whose only declaration is the index name. This
+ -- loop is not attached to the tree and does not appear as an entity local
+ -- to the protected type, so its existence need only be knwown to routines
+ -- that process entry families.
procedure Analyze_Entry_Index_Specification (N : Node_Id) is
Iden : constant Node_Id := Defining_Identifier (N);
----------------------------
procedure Analyze_Protected_Body (N : Node_Id) is
- Body_Id : constant Entity_Id := Defining_Identifier (N);
- Last_E : Entity_Id;
+ Body_Id : constant Entity_Id := Defining_Identifier (N);
+ Last_E : Entity_Id;
Spec_Id : Entity_Id;
-- This is initially the entity of the protected object or protected
Analyze_Declarations (Declarations (N));
- -- For visibility purposes, all entities in the body are private.
- -- Set First_Private_Entity accordingly, if there was no private
- -- part in the protected declaration.
+ -- For visibility purposes, all entities in the body are private. Set
+ -- First_Private_Entity accordingly, if there was no private part in the
+ -- protected declaration.
if No (First_Private_Entity (Spec_Id)) then
if Present (Last_E) then
if Present (L) then
Set_First_Private_Entity (Current_Scope, Next_Entity (L));
-
else
Set_First_Private_Entity (Current_Scope,
First_Entity (Current_Scope));
Iface, Iface_Typ);
else
- -- Ada 2005 (AI-251): "The declaration of a specific
- -- descendant of an interface type freezes the interface
- -- type" RM 13.14
+ -- Ada 2005 (AI-251): "The declaration of a specific descendant
+ -- of an interface type freezes the interface type" RM 13.14.
Freeze_Before (N, Etype (Iface));
Next (Iface);
end loop;
+
+ -- If this is the full-declaration associated with a private
+ -- declaration that implement interfaces, then the private type
+ -- declaration must be limited.
+
+ if Has_Private_Declaration (T) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Scope (T));
+ loop
+ pragma Assert (Present (E));
+
+ if Is_Type (E) and then Present (Full_View (E)) then
+ exit when Full_View (E) = T;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if not Is_Limited_Record (E) then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N
+ ("(Ada 2005) private type declaration # must be limited",
+ T);
+ end if;
+ end;
+ end if;
end if;
if Present (Discriminant_Specifications (N)) then
if Has_Discriminants (T) then
-- Install discriminants. Also, verify conformance of
- -- discriminants of previous and current view. ???
+ -- discriminants of previous and current view. ???
Install_Declarations (T);
else
Set_Has_Controlled_Component (T, True);
end if;
- -- The Ekind of components is E_Void during analysis to detect
- -- illegal uses. Now it can be set correctly.
+ -- The Ekind of components is E_Void during analysis to detect illegal
+ -- uses. Now it can be set correctly.
E := First_Entity (Current_Scope);
while Present (E) loop
Entry_Name := Selector_Name (Entry_Name);
end if;
- -- If an explicit target object is given then we have to check
- -- the restrictions of 9.5.4(6).
+ -- If an explicit target object is given then we have to check the
+ -- restrictions of 9.5.4(6).
if Present (Target_Obj) then
pragma Assert (Present (Outer_Ent));
- -- Check that the accessibility level of the target object
- -- is not greater or equal to the outermost enclosing accept
- -- statement (or entry body) unless it is a parameter of the
- -- innermost enclosing accept statement (or entry body).
+ -- Check that the accessibility level of the target object is not
+ -- greater or equal to the outermost enclosing accept statement (or
+ -- entry body) unless it is a parameter of the innermost enclosing
+ -- accept statement (or entry body).
if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
and then
-- Non-overloaded cases
- -- For the case of a reference to an element of an entry family,
- -- the Entry_Name is an indexed component.
+ -- For the case of a reference to an element of an entry family, the
+ -- Entry_Name is an indexed component.
elsif Nkind (Entry_Name) = N_Indexed_Component then
end if;
-- If we had a requeue of the form REQUEUE A (B), then the parser
- -- accepted it (because it could have been a requeue on an entry
- -- index. If A turns out not to be an entry family, then the analysis
- -- of A (B) turned it into a function call.
+ -- accepted it (because it could have been a requeue on an entry index.
+ -- If A turns out not to be an entry family, then the analysis of A (B)
+ -- turned it into a function call.
elsif Nkind (Entry_Name) = N_Function_Call then
Error_Msg_N
Ent := First_Formal (Enclosing);
while Present (Ent) loop
- -- For OUT or IN OUT parameter, the effect of the requeue
- -- is to assign the parameter a value on exit from the
- -- requeued body, so we can set it as source assigned.
- -- We also clear the Is_True_Constant indication. We do
- -- not need to clear Current_Value, since the effect of
- -- the requeue is to perform an unconditional goto so
- -- that any further references will not occur anyway.
+ -- For OUT or IN OUT parameter, the effect of the requeue is
+ -- to assign the parameter a value on exit from the requeued
+ -- body, so we can set it as source assigned. We also clear
+ -- the Is_True_Constant indication. We do not need to clear
+ -- Current_Value, since the effect of the requeue is to
+ -- perform an unconditional goto so that any further
+ -- references will not occur anyway.
if Ekind (Ent) = E_Out_Parameter
or else
end if;
-- For all parameters, the requeue acts as a reference,
- -- since the value of the parameter is passed to the
- -- new entry, so we want to suppress unreferenced warnings.
+ -- since the value of the parameter is passed to the new
+ -- entry, so we want to suppress unreferenced warnings.
Set_Referenced (Ent);
Next_Formal (Ent);
Generate_Definition (Id);
Tasking_Used := True;
- -- The node is rewritten as a protected type declaration,
- -- in exact analogy with what is done with single tasks.
+ -- The node is rewritten as a protected type declaration, in exact
+ -- analogy with what is done with single tasks.
T :=
Make_Defining_Identifier (Sloc (Id),
Protected_Definition => Relocate_Node (Protected_Definition (N)),
Interface_List => Interface_List (N));
- -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
- -- the attribute 'access
-
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
- Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
- -- Enter names of type and object before analysis, because the name
- -- of the object may be used in its own body.
+ -- Enter names of type and object before analysis, because the name of
+ -- the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Protected_Type);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
- -- Instead of calling Analyze on the new node, call directly
- -- the proper analysis procedure. Otherwise the node would be
- -- expanded twice, with disastrous result.
+ -- Instead of calling Analyze on the new node, call the proper analysis
+ -- procedure directly. Otherwise the node would be expanded twice, with
+ -- disastrous result.
Analyze_Protected_Type (N);
end Analyze_Single_Protected;
Generate_Definition (Id);
Tasking_Used := True;
- -- The node is rewritten as a task type declaration, followed
- -- by an object declaration of that anonymous task type.
+ -- The node is rewritten as a task type declaration, followed by an
+ -- object declaration of that anonymous task type.
T :=
Make_Defining_Identifier (Sloc (Id),
Task_Definition => Relocate_Node (Task_Definition (N)),
Interface_List => Interface_List (N));
- -- Ada 2005 (AI-399): Mark the object as aliased. Required to use
- -- the attribute 'access
-
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
- Aliased_Present => Ada_Version >= Ada_05,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
- -- Enter names of type and object before analysis, because the name
- -- of the object may be used in its own body.
+ -- Enter names of type and object before analysis, because the name of
+ -- the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Task_Type);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
- -- Instead of calling Analyze on the new node, call directly
- -- the proper analysis procedure. Otherwise the node would be
- -- expanded twice, with disastrous result.
+ -- Instead of calling Analyze on the new node, call the proper analysis
+ -- procedure directly. Otherwise the node would be expanded twice, with
+ -- disastrous result.
Analyze_Task_Type (N);
end Analyze_Single_Task;
Last_E : Entity_Id;
Spec_Id : Entity_Id;
- -- This is initially the entity of the task or task type involved,
- -- but is replaced by the task type always in the case of a single
- -- task declaration, since this is the proper scope to be used.
+ -- This is initially the entity of the task or task type involved, but
+ -- is replaced by the task type always in the case of a single task
+ -- declaration, since this is the proper scope to be used.
Ref_Id : Entity_Id;
- -- This is the entity of the task or task type, and is the entity
- -- used for cross-reference purposes (it differs from Spec_Id in
- -- the case of a single task, since Spec_Id is set to the task type)
+ -- This is the entity of the task or task type, and is the entity used
+ -- for cross-reference purposes (it differs from Spec_Id in the case of
+ -- a single task, since Spec_Id is set to the task type)
begin
Tasking_Used := True;
Analyze_Declarations (Declarations (N));
- -- For visibility purposes, all entities in the body are private.
- -- Set First_Private_Entity accordingly, if there was no private
- -- part in the protected declaration.
+ -- For visibility purposes, all entities in the body are private. Set
+ -- First_Private_Entity accordingly, if there was no private part in the
+ -- protected declaration.
if No (First_Private_Entity (Spec_Id)) then
if Present (Last_E) then
Next (Iface);
end loop;
+
+ -- If this is the full-declaration associated with a private
+ -- declaration that implement interfaces, then the private
+ -- type declaration must be limited.
+
+ if Has_Private_Declaration (T) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Scope (T));
+ loop
+ pragma Assert (Present (E));
+
+ if Is_Type (E) and then Present (Full_View (E)) then
+ exit when Full_View (E) = T;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ if not Is_Limited_Record (E) then
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N
+ ("(Ada 2005) private type declaration # must be limited",
+ T);
+ end if;
+ end;
+ end if;
end if;
if Present (Discriminant_Specifications (N)) then
Next (Decl);
end loop;
- -- The protected or task type is not implementing an interface,
- -- we need to check for the presence of "overriding" entries or
- -- subprograms and flag them as erroneous.
+ -- The protected or task type is not implementing an interface, we need
+ -- to check for the presence of "overriding" entries or subprograms and
+ -- flag them as erroneous.
else
Decl := First (Vis_Decls);
procedure Install_Declarations (Spec : Entity_Id) is
E : Entity_Id;
Prev : Entity_Id;
-
begin
E := First_Entity (Spec);
while Present (E) loop
OSDN Git Service
