diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 1038 |
1 files changed, 748 insertions, 290 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 42063827760..0ae717cfccd 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -53,6 +53,7 @@ with Sem_Attr; use Sem_Attr; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; @@ -941,6 +942,45 @@ package body Sem_Util is and then not In_Same_Extended_Unit (N, T); end Bad_Unordered_Enumeration_Reference; + ---------------------------- + -- Begin_Keyword_Location -- + ---------------------------- + + function Begin_Keyword_Location (N : Node_Id) return Source_Ptr is + HSS : Node_Id; + + begin + pragma Assert (Nkind_In (N, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Subprogram_Body, + N_Task_Body)); + + HSS := Handled_Statement_Sequence (N); + + -- When the handled sequence of statements comes from source, the + -- location of the "begin" keyword is that of the sequence itself. + -- Note that an internal construct may inherit a source sequence. + + if Comes_From_Source (HSS) then + return Sloc (HSS); + + -- The parser generates an internal handled sequence of statements to + -- capture the location of the "begin" keyword if present in the source. + -- Since there are no source statements, the location of the "begin" + -- keyword is effectively that of the "end" keyword. + + elsif Comes_From_Source (N) then + return Sloc (HSS); + + -- Otherwise the construct is internal and should carry the location of + -- the original construct which prompted its creation. + + else + return Sloc (N); + end if; + end Begin_Keyword_Location; + -------------------------- -- Build_Actual_Subtype -- -------------------------- @@ -5760,11 +5800,10 @@ package body Sem_Util is --------------------- function Defining_Entity - (N : Node_Id; - Empty_On_Errors : Boolean := False) return Entity_Id + (N : Node_Id; + Empty_On_Errors : Boolean := False; + Concurrent_Subunit : Boolean := False) return Entity_Id is - Err : Entity_Id := Empty; - begin case Nkind (N) is when N_Abstract_Subprogram_Declaration @@ -5816,7 +5855,23 @@ package body Sem_Util is return Defining_Identifier (N); when N_Subunit => - return Defining_Entity (Proper_Body (N)); + declare + Bod : constant Node_Id := Proper_Body (N); + Orig_Bod : constant Node_Id := Original_Node (Bod); + + begin + -- Retrieve the entity of the original protected or task body + -- if requested by the caller. + + if Concurrent_Subunit + and then Nkind (Bod) = N_Null_Statement + and then Nkind_In (Orig_Bod, N_Protected_Body, N_Task_Body) + then + return Defining_Entity (Orig_Bod); + else + return Defining_Entity (Bod); + end if; + end; when N_Function_Instantiation | N_Function_Specification @@ -5832,6 +5887,7 @@ package body Sem_Util is => declare Nam : constant Node_Id := Defining_Unit_Name (N); + Err : Entity_Id := Empty; begin if Nkind (Nam) in N_Entity then @@ -6862,6 +6918,82 @@ package body Sem_Util is end if; end Enclosing_Subprogram; + -------------------------- + -- End_Keyword_Location -- + -------------------------- + + function End_Keyword_Location (N : Node_Id) return Source_Ptr is + function End_Label_Loc (Nod : Node_Id) return Source_Ptr; + -- Return the source location of Nod's end label according to the + -- following precedence rules: + -- + -- 1) If the end label exists, return its location + -- 2) If Nod exists, return its location + -- 3) Return the location of N + + ------------------- + -- End_Label_Loc -- + ------------------- + + function End_Label_Loc (Nod : Node_Id) return Source_Ptr is + Label : Node_Id; + + begin + if Present (Nod) then + Label := End_Label (Nod); + + if Present (Label) then + return Sloc (Label); + else + return Sloc (Nod); + end if; + + else + return Sloc (N); + end if; + end End_Label_Loc; + + -- Local variables + + Owner : Node_Id; + + -- Start of processing for End_Keyword_Location + + begin + if Nkind_In (N, N_Block_Statement, + N_Entry_Body, + N_Package_Body, + N_Subprogram_Body, + N_Task_Body) + then + Owner := Handled_Statement_Sequence (N); + + elsif Nkind (N) = N_Package_Declaration then + Owner := Specification (N); + + elsif Nkind (N) = N_Protected_Body then + Owner := N; + + elsif Nkind_In (N, N_Protected_Type_Declaration, + N_Single_Protected_Declaration) + then + Owner := Protected_Definition (N); + + elsif Nkind_In (N, N_Single_Task_Declaration, + N_Task_Type_Declaration) + then + Owner := Task_Definition (N); + + -- This routine should not be called with other contexts + + else + pragma Assert (False); + null; + end if; + + return End_Label_Loc (Owner); + end End_Keyword_Location; + ------------------------ -- Ensure_Freeze_Node -- ------------------------ @@ -7735,6 +7867,93 @@ package body Sem_Util is return Empty; end Find_Enclosing_Iterator_Loop; + -------------------------- + -- Find_Enclosing_Scope -- + -------------------------- + + function Find_Enclosing_Scope (N : Node_Id) return Entity_Id is + Par : Node_Id; + Spec_Id : Entity_Id; + + begin + -- Examine the parent chain looking for a construct which defines a + -- scope. + + Par := Parent (N); + while Present (Par) loop + case Nkind (Par) is + + -- The construct denotes a declaration, the proper scope is its + -- entity. + + when N_Entry_Declaration + | N_Expression_Function + | N_Full_Type_Declaration + | N_Generic_Package_Declaration + | N_Generic_Subprogram_Declaration + | N_Package_Declaration + | N_Private_Extension_Declaration + | N_Protected_Type_Declaration + | N_Single_Protected_Declaration + | N_Single_Task_Declaration + | N_Subprogram_Declaration + | N_Task_Type_Declaration + => + return Defining_Entity (Par); + + -- The construct denotes a body, the proper scope is the entity of + -- the corresponding spec. + + when N_Entry_Body + | N_Package_Body + | N_Protected_Body + | N_Subprogram_Body + | N_Task_Body + => + Spec_Id := Corresponding_Spec (Par); + + -- The defining entity of a stand-alone subprogram body defines + -- a scope. + + if Nkind (Par) = N_Subprogram_Body and then No (Spec_Id) then + return Defining_Entity (Par); + + -- Otherwise there should be corresponding spec which defines a + -- scope. + + else + pragma Assert (Present (Spec_Id)); + + return Spec_Id; + end if; + + -- Special cases + + -- Blocks, loops, and return statements have artificial scopes + + when N_Block_Statement + | N_Loop_Statement + => + return Entity (Identifier (Par)); + + when N_Extended_Return_Statement => + return Return_Statement_Entity (Par); + + -- A traversal from a subunit continues via the corresponding stub + + when N_Subunit => + Par := Corresponding_Stub (Par); + + when others => + null; + end case; + + Par := Parent (Par); + end loop; + + return Standard_Standard; + end Find_Enclosing_Scope; + ------------------------------------ -- Find_Loop_In_Conditional_Block -- ------------------------------------ @@ -9393,7 +9612,7 @@ package body Sem_Util is -- Get_Task_Body_Procedure -- ----------------------------- - function Get_Task_Body_Procedure (E : Entity_Id) return Node_Id is + function Get_Task_Body_Procedure (E : Entity_Id) return Entity_Id is begin -- Note: A task type may be the completion of a private type with -- discriminants. When performing elaboration checks on a task @@ -10523,12 +10742,14 @@ package body Sem_Util is -- Has_Non_Trivial_Precondition -- ---------------------------------- - function Has_Non_Trivial_Precondition (P : Entity_Id) return Boolean is - Cont : constant Node_Id := Find_Aspect (P, Aspect_Pre); + function Has_Non_Trivial_Precondition (Subp : Entity_Id) return Boolean is + Pre : constant Node_Id := Find_Aspect (Subp, Aspect_Pre); + begin - return Present (Cont) - and then Class_Present (Cont) - and then not Is_Entity_Name (Expression (Cont)); + return + Present (Pre) + and then Class_Present (Pre) + and then not Is_Entity_Name (Expression (Pre)); end Has_Non_Trivial_Precondition; ------------------- @@ -10769,160 +10990,6 @@ package body Sem_Util is Ent : Entity_Id; Exp : Node_Id; - function Is_Preelaborable_Expression (N : Node_Id) return Boolean; - -- Returns True if and only if the expression denoted by N does not - -- violate restrictions on preelaborable constructs (RM-10.2.1(5-9)). - - --------------------------------- - -- Is_Preelaborable_Expression -- - --------------------------------- - - function Is_Preelaborable_Expression (N : Node_Id) return Boolean is - Exp : Node_Id; - Assn : Node_Id; - Choice : Node_Id; - Comp_Type : Entity_Id; - Is_Array_Aggr : Boolean; - - begin - if Is_OK_Static_Expression (N) then - return True; - - elsif Nkind (N) = N_Null then - return True; - - -- Attributes are allowed in general, even if their prefix is a - -- formal type. (It seems that certain attributes known not to be - -- static might not be allowed, but there are no rules to prevent - -- them.) - - elsif Nkind (N) = N_Attribute_Reference then - return True; - - -- The name of a discriminant evaluated within its parent type is - -- defined to be preelaborable (10.2.1(8)). Note that we test for - -- names that denote discriminals as well as discriminants to - -- catch references occurring within init procs. - - elsif Is_Entity_Name (N) - and then - (Ekind (Entity (N)) = E_Discriminant - or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) - and then Present (Discriminal_Link (Entity (N))))) - then - return True; - - elsif Nkind (N) = N_Qualified_Expression then - return Is_Preelaborable_Expression (Expression (N)); - - -- For aggregates we have to check that each of the associations - -- is preelaborable. - - elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then - Is_Array_Aggr := Is_Array_Type (Etype (N)); - - if Is_Array_Aggr then - Comp_Type := Component_Type (Etype (N)); - end if; - - -- Check the ancestor part of extension aggregates, which must - -- be either the name of a type that has preelaborable init or - -- an expression that is preelaborable. - - if Nkind (N) = N_Extension_Aggregate then - declare - Anc_Part : constant Node_Id := Ancestor_Part (N); - - begin - if Is_Entity_Name (Anc_Part) - and then Is_Type (Entity (Anc_Part)) - then - if not Has_Preelaborable_Initialization - (Entity (Anc_Part)) - then - return False; - end if; - - elsif not Is_Preelaborable_Expression (Anc_Part) then - return False; - end if; - end; - end if; - - -- Check positional associations - - Exp := First (Expressions (N)); - while Present (Exp) loop - if not Is_Preelaborable_Expression (Exp) then - return False; - end if; - - Next (Exp); - end loop; - - -- Check named associations - - Assn := First (Component_Associations (N)); - while Present (Assn) loop - Choice := First (Choices (Assn)); - while Present (Choice) loop - if Is_Array_Aggr then - if Nkind (Choice) = N_Others_Choice then - null; - - elsif Nkind (Choice) = N_Range then - if not Is_OK_Static_Range (Choice) then - return False; - end if; - - elsif not Is_OK_Static_Expression (Choice) then - return False; - end if; - - else - Comp_Type := Etype (Choice); - end if; - - Next (Choice); - end loop; - - -- If the association has a <> at this point, then we have - -- to check whether the component's type has preelaborable - -- initialization. Note that this only occurs when the - -- association's corresponding component does not have a - -- default expression, the latter case having already been - -- expanded as an expression for the association. - - if Box_Present (Assn) then - if not Has_Preelaborable_Initialization (Comp_Type) then - return False; - end if; - - -- In the expression case we check whether the expression - -- is preelaborable. - - elsif - not Is_Preelaborable_Expression (Expression (Assn)) - then - return False; - end if; - - Next (Assn); - end loop; - - -- If we get here then aggregate as a whole is preelaborable - - return True; - - -- All other cases are not preelaborable - - else - return False; - end if; - end Is_Preelaborable_Expression; - - -- Start of processing for Check_Components - begin -- Loop through entities of record or protected type @@ -10969,7 +11036,7 @@ package body Sem_Util is -- Require the default expression to be preelaborable - elsif not Is_Preelaborable_Expression (Exp) then + elsif not Is_Preelaborable_Construct (Exp) then Has_PE := False; exit; end if; @@ -11714,21 +11781,23 @@ package body Sem_Util is -- In_Instance_Visible_Part -- ------------------------------ - function In_Instance_Visible_Part return Boolean is - S : Entity_Id; + function In_Instance_Visible_Part + (Id : Entity_Id := Current_Scope) return Boolean + is + Inst : Entity_Id; begin - S := Current_Scope; - while Present (S) and then S /= Standard_Standard loop - if Ekind (S) = E_Package - and then Is_Generic_Instance (S) - and then not In_Package_Body (S) - and then not In_Private_Part (S) + Inst := Id; + while Present (Inst) and then Inst /= Standard_Standard loop + if Ekind (Inst) = E_Package + and then Is_Generic_Instance (Inst) + and then not In_Package_Body (Inst) + and then not In_Private_Part (Inst) then return True; end if; - S := Scope (S); + Inst := Scope (Inst); end loop; return False; @@ -11887,7 +11956,7 @@ package body Sem_Util is -- In_Subtree -- ---------------- - function In_Subtree (Root : Node_Id; N : Node_Id) return Boolean is + function In_Subtree (N : Node_Id; Root : Node_Id) return Boolean is Curr : Node_Id; begin @@ -11903,6 +11972,30 @@ package body Sem_Util is return False; end In_Subtree; + ---------------- + -- In_Subtree -- + ---------------- + + function In_Subtree + (N : Node_Id; + Root1 : Node_Id; + Root2 : Node_Id) return Boolean + is + Curr : Node_Id; + + begin + Curr := N; + while Present (Curr) loop + if Curr = Root1 or else Curr = Root2 then + return True; + end if; + + Curr := Parent (Curr); + end loop; + + return False; + end In_Subtree; + --------------------- -- In_Visible_Part -- --------------------- @@ -15287,6 +15380,162 @@ package body Sem_Util is end if; end Is_Potentially_Unevaluated; + -------------------------------- + -- Is_Preelaborable_Aggregate -- + -------------------------------- + + function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean is + Aggr_Typ : constant Entity_Id := Etype (Aggr); + Array_Aggr : constant Boolean := Is_Array_Type (Aggr_Typ); + + Anc_Part : Node_Id; + Assoc : Node_Id; + Choice : Node_Id; + Comp_Typ : Entity_Id; + Expr : Node_Id; + + begin + if Array_Aggr then + Comp_Typ := Component_Type (Aggr_Typ); + end if; + + -- Inspect the ancestor part + + if Nkind (Aggr) = N_Extension_Aggregate then + Anc_Part := Ancestor_Part (Aggr); + + -- The ancestor denotes a subtype mark + + if Is_Entity_Name (Anc_Part) + and then Is_Type (Entity (Anc_Part)) + then + if not Has_Preelaborable_Initialization (Entity (Anc_Part)) then + return False; + end if; + + -- Otherwise the ancestor denotes an expression + + elsif not Is_Preelaborable_Construct (Anc_Part) then + return False; + end if; + end if; + + -- Inspect the positional associations + + Expr := First (Expressions (Aggr)); + while Present (Expr) loop + if not Is_Preelaborable_Construct (Expr) then + return False; + end if; + + Next (Expr); + end loop; + + -- Inspect the named associations + + Assoc := First (Component_Associations (Aggr)); + while Present (Assoc) loop + + -- Inspect the choices of the current named association + + Choice := First (Choices (Assoc)); + while Present (Choice) loop + if Array_Aggr then + + -- For a choice to be preelaborable, it must denote either a + -- static range or a static expression. + + if Nkind (Choice) = N_Others_Choice then + null; + + elsif Nkind (Choice) = N_Range then + if not Is_OK_Static_Range (Choice) then + return False; + end if; + + elsif not Is_OK_Static_Expression (Choice) then + return False; + end if; + + else + Comp_Typ := Etype (Choice); + end if; + + Next (Choice); + end loop; + + -- The type of the choice must have preelaborable initialization if + -- the association carries a <>. + + if Box_Present (Assoc) then + if not Has_Preelaborable_Initialization (Comp_Typ) then + return False; + end if; + + -- The type of the expression must have preelaborable initialization + + elsif not Is_Preelaborable_Construct (Expression (Assoc)) then + return False; + end if; + + Next (Assoc); + end loop; + + -- At this point the aggregate is preelaborable + + return True; + end Is_Preelaborable_Aggregate; + + -------------------------------- + -- Is_Preelaborable_Construct -- + -------------------------------- + + function Is_Preelaborable_Construct (N : Node_Id) return Boolean is + begin + -- Aggregates + + if Nkind_In (N, N_Aggregate, N_Extension_Aggregate) then + return Is_Preelaborable_Aggregate (N); + + -- Attributes are allowed in general, even if their prefix is a formal + -- type. It seems that certain attributes known not to be static might + -- not be allowed, but there are no rules to prevent them. + + elsif Nkind (N) = N_Attribute_Reference then + return True; + + -- Expressions + + elsif Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then + return True; + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Preelaborable_Construct (Expression (N)); + + -- Names are preelaborable when they denote a discriminant of an + -- enclosing type. Discriminals are also considered for this check. + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then + (Ekind (Entity (N)) = E_Discriminant + or else (Ekind_In (Entity (N), E_Constant, E_In_Parameter) + and then Present (Discriminal_Link (Entity (N))))) + then + return True; + + -- Statements + + elsif Nkind (N) = N_Null then + return True; + + -- Otherwise the construct is not preelaborable + + else + return False; + end if; + end Is_Preelaborable_Construct; + --------------------------------- -- Is_Protected_Self_Reference -- --------------------------------- @@ -16941,6 +17190,306 @@ package body Sem_Util is return N; end Last_Source_Statement; + ----------------------- + -- Mark_Coextensions -- + ----------------------- + + procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is + Is_Dynamic : Boolean; + -- Indicates whether the context causes nested coextensions to be + -- dynamic or static + + function Mark_Allocator (N : Node_Id) return Traverse_Result; + -- Recognize an allocator node and label it as a dynamic coextension + + -------------------- + -- Mark_Allocator -- + -------------------- + + function Mark_Allocator (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Allocator then + if Is_Dynamic then + Set_Is_Dynamic_Coextension (N); + + -- If the allocator expression is potentially dynamic, it may + -- be expanded out of order and require dynamic allocation + -- anyway, so we treat the coextension itself as dynamic. + -- Potential optimization ??? + + elsif Nkind (Expression (N)) = N_Qualified_Expression + and then Nkind (Expression (Expression (N))) = N_Op_Concat + then + Set_Is_Dynamic_Coextension (N); + else + Set_Is_Static_Coextension (N); + end if; + end if; + + return OK; + end Mark_Allocator; + + procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); + + -- Start of processing for Mark_Coextensions + + begin + -- An allocator that appears on the right-hand side of an assignment is + -- treated as a potentially dynamic coextension when the right-hand side + -- is an allocator or a qualified expression. + + -- Obj := new ...'(new Coextension ...); + + if Nkind (Context_Nod) = N_Assignment_Statement then + Is_Dynamic := + Nkind_In (Expression (Context_Nod), N_Allocator, + N_Qualified_Expression); + + -- An allocator that appears within the expression of a simple return + -- statement is treated as a potentially dynamic coextension when the + -- expression is either aggregate, allocator, or qualified expression. + + -- return (new Coextension ...); + -- return new ...'(new Coextension ...); + + elsif Nkind (Context_Nod) = N_Simple_Return_Statement then + Is_Dynamic := + Nkind_In (Expression (Context_Nod), N_Aggregate, + N_Allocator, + N_Qualified_Expression); + + -- An alloctor that appears within the initialization expression of an + -- object declaration is considered a potentially dynamic coextension + -- when the initialization expression is an allocator or a qualified + -- expression. + + -- Obj : ... := new ...'(new Coextension ...); + + -- A similar case arises when the object declaration is part of an + -- extended return statement. + + -- return Obj : ... := new ...'(new Coextension ...); + -- return Obj : ... := (new Coextension ...); + + elsif Nkind (Context_Nod) = N_Object_Declaration then + Is_Dynamic := + Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) + or else + Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; + + -- This routine should not be called with constructs that cannot contain + -- coextensions. + + else + raise Program_Error; + end if; + + Mark_Allocators (Root_Nod); + end Mark_Coextensions; + + --------------------------------- + -- Mark_Elaboration_Attributes -- + --------------------------------- + + procedure Mark_Elaboration_Attributes + (N_Id : Node_Or_Entity_Id; + Checks : Boolean := False; + Level : Boolean := False; + Modes : Boolean := False) + is + function Elaboration_Checks_OK + (Target_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean; + -- Determine whether elaboration checks are enabled for target Target_Id + -- which resides within context Context_Id. + + procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id); + -- Preserve relevant attributes of the context in arbitrary entity Id + + procedure Mark_Elaboration_Attributes_Node (N : Node_Id); + -- Preserve relevant attributes of the context in arbitrary node N + + --------------------------- + -- Elaboration_Checks_OK -- + --------------------------- + + function Elaboration_Checks_OK + (Target_Id : Entity_Id; + Context_Id : Entity_Id) return Boolean + is + Encl_Scop : Entity_Id; + + begin + -- Elaboration checks are suppressed for the target + + if Elaboration_Checks_Suppressed (Target_Id) then + return False; + end if; + + -- Otherwise elaboration checks are OK for the target, but may be + -- suppressed for the context where the target is declared. + + Encl_Scop := Context_Id; + while Present (Encl_Scop) and then Encl_Scop /= Standard_Standard loop + if Elaboration_Checks_Suppressed (Encl_Scop) then + return False; + end if; + + Encl_Scop := Scope (Encl_Scop); + end loop; + + -- Neither the target nor its declarative context have elaboration + -- checks suppressed. + + return True; + end Elaboration_Checks_OK; + + ------------------------------------ + -- Mark_Elaboration_Attributes_Id -- + ------------------------------------ + + procedure Mark_Elaboration_Attributes_Id (Id : Entity_Id) is + begin + -- Mark the status of elaboration checks in effect. Do not reset the + -- status in case the entity is reanalyzed with checks suppressed. + + if Checks and then not Is_Elaboration_Checks_OK_Id (Id) then + Set_Is_Elaboration_Checks_OK_Id (Id, + Elaboration_Checks_OK + (Target_Id => Id, + Context_Id => Scope (Id))); + + -- Entities do not need to capture their enclosing level. The Ghost + -- and SPARK modes in effect are already marked during analysis. + + else + null; + end if; + end Mark_Elaboration_Attributes_Id; + + -------------------------------------- + -- Mark_Elaboration_Attributes_Node -- + -------------------------------------- + + procedure Mark_Elaboration_Attributes_Node (N : Node_Id) is + function Extract_Name (N : Node_Id) return Node_Id; + -- Obtain the Name attribute of call or instantiation N + + ------------------ + -- Extract_Name -- + ------------------ + + function Extract_Name (N : Node_Id) return Node_Id is + Nam : Node_Id; + + begin + Nam := Name (N); + + -- A call to an entry family appears in indexed form + + if Nkind (Nam) = N_Indexed_Component then + Nam := Prefix (Nam); + end if; + + -- The name may also appear in qualified form + + if Nkind (Nam) = N_Selected_Component then + Nam := Selector_Name (Nam); + end if; + + return Nam; + end Extract_Name; + + -- Local variables + + Context_Id : Entity_Id; + Nam : Node_Id; + + -- Start of processing for Mark_Elaboration_Attributes_Node + + begin + -- Mark the status of elaboration checks in effect. Do not reset the + -- status in case the node is reanalyzed with checks suppressed. + + if Checks and then not Is_Elaboration_Checks_OK_Node (N) then + + -- Assignments, attribute references, and variable references do + -- not have a "declarative" context. + + Context_Id := Empty; + + -- The status of elaboration checks for calls and instantiations + -- depends on the most recent pragma Suppress/Unsuppress, as well + -- as the suppression status of the context where the target is + -- defined. + + -- package Pack is + -- function Func ...; + -- end Pack; + + -- with Pack; + -- procedure Main is + -- pragma Suppress (Elaboration_Checks, Pack); + -- X : ... := Pack.Func; + -- ... + + -- In the example above, the call to Func has elaboration checks + -- enabled because there is no active general purpose suppression + -- pragma, however the elaboration checks of Pack are explicitly + -- suppressed. As a result the elaboration checks of the call must + -- be disabled in order to preserve this dependency. + + if Nkind_In (N, N_Entry_Call_Statement, + N_Function_Call, + N_Function_Instantiation, + N_Package_Instantiation, + N_Procedure_Call_Statement, + N_Procedure_Instantiation) + then + Nam := Extract_Name (N); + + if Is_Entity_Name (Nam) and then Present (Entity (Nam)) then + Context_Id := Scope (Entity (Nam)); + end if; + end if; + + Set_Is_Elaboration_Checks_OK_Node (N, + Elaboration_Checks_OK + (Target_Id => Empty, + Context_Id => Context_Id)); + end if; + + -- Mark the enclosing level of the node. Do not reset the status in + -- case the node is relocated and reanalyzed. + + if Level and then not Is_Declaration_Level_Node (N) then + Set_Is_Declaration_Level_Node (N, + Find_Enclosing_Level (N) = Declaration_Level); + end if; + + -- Mark the Ghost and SPARK mode in effect + + if Modes then + if Ghost_Mode = Ignore then + Set_Is_Ignored_Ghost_Node (N); + end if; + + if SPARK_Mode = On then + Set_Is_SPARK_Mode_On_Node (N); + end if; + end if; + end Mark_Elaboration_Attributes_Node; + + -- Start of processing for Mark_Elaboration_Attributes + + begin + if Nkind (N_Id) in N_Entity then + Mark_Elaboration_Attributes_Id (N_Id); + else + Mark_Elaboration_Attributes_Node (N_Id); + end if; + end Mark_Elaboration_Attributes; + ---------------------------------- -- Matching_Static_Array_Bounds -- ---------------------------------- @@ -17245,103 +17794,6 @@ package body Sem_Util is end case; end May_Be_Lvalue; - ----------------------- - -- Mark_Coextensions -- - ----------------------- - - procedure Mark_Coextensions (Context_Nod : Node_Id; Root_Nod : Node_Id) is - Is_Dynamic : Boolean; - -- Indicates whether the context causes nested coextensions to be - -- dynamic or static - - function Mark_Allocator (N : Node_Id) return Traverse_Result; - -- Recognize an allocator node and label it as a dynamic coextension - - -------------------- - -- Mark_Allocator -- - -------------------- - - function Mark_Allocator (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Allocator then - if Is_Dynamic then - Set_Is_Dynamic_Coextension (N); - - -- If the allocator expression is potentially dynamic, it may - -- be expanded out of order and require dynamic allocation - -- anyway, so we treat the coextension itself as dynamic. - -- Potential optimization ??? - - elsif Nkind (Expression (N)) = N_Qualified_Expression - and then Nkind (Expression (Expression (N))) = N_Op_Concat - then - Set_Is_Dynamic_Coextension (N); - else - Set_Is_Static_Coextension (N); - end if; - end if; - - return OK; - end Mark_Allocator; - - procedure Mark_Allocators is new Traverse_Proc (Mark_Allocator); - - -- Start of processing for Mark_Coextensions - - begin - -- An allocator that appears on the right-hand side of an assignment is - -- treated as a potentially dynamic coextension when the right-hand side - -- is an allocator or a qualified expression. - - -- Obj := new ...'(new Coextension ...); - - if Nkind (Context_Nod) = N_Assignment_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Allocator, - N_Qualified_Expression); - - -- An allocator that appears within the expression of a simple return - -- statement is treated as a potentially dynamic coextension when the - -- expression is either aggregate, allocator, or qualified expression. - - -- return (new Coextension ...); - -- return new ...'(new Coextension ...); - - elsif Nkind (Context_Nod) = N_Simple_Return_Statement then - Is_Dynamic := - Nkind_In (Expression (Context_Nod), N_Aggregate, - N_Allocator, - N_Qualified_Expression); - - -- An allocator that appears within the initialization expression of an - -- object declaration is considered a potentially dynamic coextension - -- when the initialization expression is an allocator or a qualified - -- expression. - - -- Obj : ... := new ...'(new Coextension ...); - - -- A similar case arises when the object declaration is part of an - -- extended return statement. - - -- return Obj : ... := new ...'(new Coextension ...); - -- return Obj : ... := (new Coextension ...); - - elsif Nkind (Context_Nod) = N_Object_Declaration then - Is_Dynamic := - Nkind_In (Root_Nod, N_Allocator, N_Qualified_Expression) - or else - Nkind (Parent (Context_Nod)) = N_Extended_Return_Statement; - - -- This routine should not be called with constructs that cannot contain - -- coextensions. - - else - raise Program_Error; - end if; - - Mark_Allocators (Root_Nod); - end Mark_Coextensions; - ----------------- -- Might_Raise -- ----------------- @@ -18508,8 +18960,8 @@ package body Sem_Util is -- the subtree being replicated. elsif not In_Subtree - (Root => Source, - N => Declaration_Node (Id)) + (N => Declaration_Node (Id), + Root => Source) then return; end if; @@ -18653,8 +19105,8 @@ package body Sem_Util is -- the subtree being replicated. elsif not In_Subtree - (Root => Source, - N => Associated_Node_For_Itype (Itype)) + (N => Associated_Node_For_Itype (Itype), + Root => Source) then return; end if; @@ -21986,15 +22438,18 @@ package body Sem_Util is -- Scope_Within -- ------------------ - function Scope_Within (Scope1, Scope2 : Entity_Id) return Boolean is - Scop : Entity_Id; + function Scope_Within + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean + is + Curr : Entity_Id; begin - Scop := Scope1; - while Scop /= Standard_Standard loop - Scop := Scope (Scop); + Curr := Inner; + while Present (Curr) and then Curr /= Standard_Standard loop + Curr := Scope (Curr); - if Scop = Scope2 then + if Curr = Outer then return True; end if; end loop; @@ -22006,17 +22461,20 @@ package body Sem_Util is -- Scope_Within_Or_Same -- -------------------------- - function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean is - Scop : Entity_Id; + function Scope_Within_Or_Same + (Inner : Entity_Id; + Outer : Entity_Id) return Boolean + is + Curr : Entity_Id; begin - Scop := Scope1; - while Scop /= Standard_Standard loop - if Scop = Scope2 then + Curr := Inner; + while Present (Curr) and then Curr /= Standard_Standard loop + if Curr = Outer then return True; - else - Scop := Scope (Scop); end if; + + Curr := Scope (Curr); end loop; return False; |