diff options
| -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 |