diff options
author | Javier Miranda <miranda@adacore.com> | 2006-02-15 10:45:00 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2006-02-15 10:45:00 +0100 |
commit | d97d1726450be2730e9dab700a0ffddd838a6753 (patch) | |
tree | 90881b527ff74f29dc63f194427a3d96b36d1497 /gcc | |
parent | cdc8c54cf73e3b3d5cd5d3431a76a0fbd1c42908 (diff) | |
download | gcc-d97d1726450be2730e9dab700a0ffddd838a6753.zip gcc-d97d1726450be2730e9dab700a0ffddd838a6753.tar.gz gcc-d97d1726450be2730e9dab700a0ffddd838a6753.tar.bz2 |
sem_ch9.adb (Analyze_Protected_Type, [...]): Check that if this is the full-declaration associated with a private...
2006-02-13 Javier Miranda <miranda@adacore.com>
* sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): Check that
if this is the full-declaration associated with a private declaration
that implement interfaces, then the private type declaration must be
limited.
(Analyze_Single_Protected, Analyze_Single_Task): Do not mark the object
as aliased. The use of the 'access attribute is not available for such
object (for this purpose the object should be explicitly marked as
aliased, but being an anonymous type this is not possible).
From-SVN: r111094
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/sem_ch9.adb | 299 |
1 files changed, 171 insertions, 128 deletions
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index dc34ada..1ce2efd 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -70,16 +70,16 @@ package body Sem_Ch9 is 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 -- @@ -162,9 +162,9 @@ package body Sem_Ch9 is ----------------------- 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); @@ -183,13 +183,11 @@ package body Sem_Ch9 is 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); @@ -272,9 +270,9 @@ package body Sem_Ch9 is 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); @@ -300,8 +298,8 @@ package body Sem_Ch9 is 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 @@ -365,12 +363,11 @@ package body Sem_Ch9 is 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; @@ -390,25 +387,25 @@ package body Sem_Ch9 is 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); @@ -462,12 +459,12 @@ package body Sem_Ch9 is 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 @@ -540,7 +537,7 @@ package body Sem_Ch9 is 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. @@ -668,13 +665,13 @@ package body Sem_Ch9 is (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 := @@ -692,8 +689,8 @@ package body Sem_Ch9 is 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); @@ -781,8 +778,8 @@ package body Sem_Ch9 is -- 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); @@ -793,9 +790,9 @@ package body Sem_Ch9 is 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; @@ -836,7 +833,6 @@ package body Sem_Ch9 is then End_Scope; end if; - end Analyze_Entry_Body; ------------------------------------ @@ -937,15 +933,15 @@ package body Sem_Ch9 is -- 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); @@ -980,8 +976,8 @@ package body Sem_Ch9 is ---------------------------- 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 @@ -1038,9 +1034,9 @@ package body Sem_Ch9 is 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 @@ -1076,7 +1072,6 @@ package body Sem_Ch9 is if Present (L) then Set_First_Private_Entity (Current_Scope, Next_Entity (L)); - else Set_First_Private_Entity (Current_Scope, First_Entity (Current_Scope)); @@ -1155,9 +1150,8 @@ package body Sem_Ch9 is 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)); @@ -1182,13 +1176,42 @@ package body Sem_Ch9 is 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 @@ -1215,8 +1238,8 @@ package body Sem_Ch9 is 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 @@ -1284,8 +1307,8 @@ package body Sem_Ch9 is 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 @@ -1306,10 +1329,10 @@ package body Sem_Ch9 is 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 @@ -1361,8 +1384,8 @@ package body Sem_Ch9 is -- 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 @@ -1382,9 +1405,9 @@ package body Sem_Ch9 is 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 @@ -1424,13 +1447,13 @@ package body Sem_Ch9 is 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 @@ -1441,8 +1464,8 @@ package body Sem_Ch9 is 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); @@ -1588,8 +1611,8 @@ package body Sem_Ch9 is 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), @@ -1601,21 +1624,17 @@ package body Sem_Ch9 is 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); @@ -1625,9 +1644,9 @@ package body Sem_Ch9 is 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; @@ -1648,8 +1667,8 @@ package body Sem_Ch9 is 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), @@ -1661,21 +1680,17 @@ package body Sem_Ch9 is 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); @@ -1685,9 +1700,9 @@ package body Sem_Ch9 is 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; @@ -1701,14 +1716,14 @@ package body Sem_Ch9 is 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; @@ -1765,9 +1780,9 @@ package body Sem_Ch9 is 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 @@ -1909,6 +1924,35 @@ package body Sem_Ch9 is 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 @@ -2338,9 +2382,9 @@ package body Sem_Ch9 is 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); @@ -2388,7 +2432,6 @@ package body Sem_Ch9 is procedure Install_Declarations (Spec : Entity_Id) is E : Entity_Id; Prev : Entity_Id; - begin E := First_Entity (Spec); while Present (E) loop |