| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ C H 9 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2019, 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- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Aspects; use Aspects; |
| with Atree; use Atree; |
| with Checks; use Checks; |
| with Contracts; use Contracts; |
| with Debug; use Debug; |
| with Einfo; use Einfo; |
| with Errout; use Errout; |
| with Exp_Ch9; use Exp_Ch9; |
| with Elists; use Elists; |
| with Freeze; use Freeze; |
| with Layout; use Layout; |
| with Lib; use Lib; |
| with Lib.Xref; use Lib.Xref; |
| with Namet; use Namet; |
| with Nlists; use Nlists; |
| with Nmake; use Nmake; |
| with Opt; use Opt; |
| with Restrict; use Restrict; |
| with Rident; use Rident; |
| with Rtsfind; use Rtsfind; |
| with Sem; use Sem; |
| with Sem_Aux; use Sem_Aux; |
| with Sem_Ch3; use Sem_Ch3; |
| with Sem_Ch5; use Sem_Ch5; |
| with Sem_Ch6; use Sem_Ch6; |
| with Sem_Ch8; use Sem_Ch8; |
| with Sem_Ch13; use Sem_Ch13; |
| with Sem_Elab; use Sem_Elab; |
| with Sem_Eval; use Sem_Eval; |
| with Sem_Prag; use Sem_Prag; |
| with Sem_Res; use Sem_Res; |
| with Sem_Type; use Sem_Type; |
| with Sem_Util; use Sem_Util; |
| with Sem_Warn; use Sem_Warn; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Sinfo; use Sinfo; |
| with Style; |
| with Tbuild; use Tbuild; |
| with Uintp; use Uintp; |
| |
| package body Sem_Ch9 is |
| |
| ----------------------- |
| -- Local Subprograms -- |
| ----------------------- |
| |
| function Allows_Lock_Free_Implementation |
| (N : Node_Id; |
| Lock_Free_Given : Boolean := False) return Boolean; |
| -- This routine returns True iff N satisfies the following list of lock- |
| -- free restrictions for protected type declaration and protected body: |
| -- |
| -- 1) Protected type declaration |
| -- May not contain entries |
| -- Protected subprogram declarations may not have non-elementary |
| -- parameters. |
| -- |
| -- 2) Protected Body |
| -- Each protected subprogram body within N must satisfy: |
| -- May reference only one protected component |
| -- May not reference non-constant entities outside the protected |
| -- subprogram scope. |
| -- May not contain address representation items, allocators and |
| -- quantified expressions. |
| -- May not contain delay, goto, loop and procedure call |
| -- statements. |
| -- May not contain exported and imported entities |
| -- May not dereference access values |
| -- Function calls and attribute references must be static |
| -- |
| -- If Lock_Free_Given is True, an error message is issued when False is |
| -- returned. |
| |
| procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions); |
| -- Given either a protected definition or a task definition in D, check |
| -- the corresponding restriction parameter identifier R, and if it is set, |
| -- count the entries (checking the static requirement), and compare with |
| -- the given maximum. |
| |
| procedure Check_Interfaces (N : Node_Id; T : Entity_Id); |
| -- N is an N_Protected_Type_Declaration or N_Task_Type_Declaration node. |
| -- Complete decoration of T and check legality of the covered interfaces. |
| |
| procedure Check_Triggering_Statement |
| (Trigger : Node_Id; |
| Error_Node : Node_Id; |
| Is_Dispatching : out Boolean); |
| -- Examine the triggering statement of a select statement, conditional or |
| -- timed entry call. If Trigger is a dispatching call, return its status |
| -- in Is_Dispatching and check whether the primitive belongs to a limited |
| -- interface. If it does not, emit an error at Error_Node. |
| |
| 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. |
| |
| ------------------------------------- |
| -- Allows_Lock_Free_Implementation -- |
| ------------------------------------- |
| |
| function Allows_Lock_Free_Implementation |
| (N : Node_Id; |
| Lock_Free_Given : Boolean := False) return Boolean |
| is |
| Errors_Count : Nat := 0; |
| -- Errors_Count is a count of errors detected by the compiler so far |
| -- when Lock_Free_Given is True. |
| |
| begin |
| pragma Assert (Nkind_In (N, N_Protected_Type_Declaration, |
| N_Protected_Body)); |
| |
| -- The lock-free implementation is currently enabled through a debug |
| -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the |
| -- lock-free implementation. In that case, the debug flag is not needed. |
| |
| if not Lock_Free_Given and then not Debug_Flag_9 then |
| return False; |
| end if; |
| |
| -- Get the number of errors detected by the compiler so far |
| |
| if Lock_Free_Given then |
| Errors_Count := Serious_Errors_Detected; |
| end if; |
| |
| -- Protected type declaration case |
| |
| if Nkind (N) = N_Protected_Type_Declaration then |
| declare |
| Pdef : constant Node_Id := Protected_Definition (N); |
| Priv_Decls : constant List_Id := Private_Declarations (Pdef); |
| Vis_Decls : constant List_Id := Visible_Declarations (Pdef); |
| Decl : Node_Id; |
| |
| begin |
| -- Examine the visible and the private declarations |
| |
| Decl := First (Vis_Decls); |
| while Present (Decl) loop |
| |
| -- Entries and entry families are not allowed by the lock-free |
| -- restrictions. |
| |
| if Nkind (Decl) = N_Entry_Declaration then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("entry not allowed when Lock_Free given", Decl); |
| else |
| return False; |
| end if; |
| |
| -- Non-elementary parameters in protected procedure are not |
| -- allowed by the lock-free restrictions. |
| |
| elsif Nkind (Decl) = N_Subprogram_Declaration |
| and then |
| Nkind (Specification (Decl)) = N_Procedure_Specification |
| and then |
| Present (Parameter_Specifications (Specification (Decl))) |
| then |
| declare |
| Par_Specs : constant List_Id := |
| Parameter_Specifications |
| (Specification (Decl)); |
| |
| Par : Node_Id; |
| |
| begin |
| Par := First (Par_Specs); |
| while Present (Par) loop |
| if not Is_Elementary_Type |
| (Etype (Defining_Identifier (Par))) |
| then |
| if Lock_Free_Given then |
| Error_Msg_NE |
| ("non-elementary parameter& not allowed " |
| & "when Lock_Free given", |
| Par, Defining_Identifier (Par)); |
| else |
| return False; |
| end if; |
| end if; |
| |
| Next (Par); |
| end loop; |
| end; |
| end if; |
| |
| -- Examine private declarations after visible declarations |
| |
| if No (Next (Decl)) |
| and then List_Containing (Decl) = Vis_Decls |
| then |
| Decl := First (Priv_Decls); |
| else |
| Next (Decl); |
| end if; |
| end loop; |
| end; |
| |
| -- Protected body case |
| |
| else |
| Protected_Body_Case : declare |
| Decls : constant List_Id := Declarations (N); |
| Pid : constant Entity_Id := Corresponding_Spec (N); |
| Prot_Typ_Decl : constant Node_Id := Parent (Pid); |
| Prot_Def : constant Node_Id := |
| Protected_Definition (Prot_Typ_Decl); |
| Priv_Decls : constant List_Id := |
| Private_Declarations (Prot_Def); |
| Decl : Node_Id; |
| |
| function Satisfies_Lock_Free_Requirements |
| (Sub_Body : Node_Id) return Boolean; |
| -- Return True if protected subprogram body Sub_Body satisfies all |
| -- requirements of a lock-free implementation. |
| |
| -------------------------------------- |
| -- Satisfies_Lock_Free_Requirements -- |
| -------------------------------------- |
| |
| function Satisfies_Lock_Free_Requirements |
| (Sub_Body : Node_Id) return Boolean |
| is |
| Is_Procedure : constant Boolean := |
| Ekind (Corresponding_Spec (Sub_Body)) = |
| E_Procedure; |
| -- Indicates if Sub_Body is a procedure body |
| |
| Comp : Entity_Id := Empty; |
| -- Track the current component which the body references |
| |
| Errors_Count : Nat := 0; |
| -- Errors_Count is a count of errors detected by the compiler |
| -- so far when Lock_Free_Given is True. |
| |
| function Check_Node (N : Node_Id) return Traverse_Result; |
| -- Check that node N meets the lock free restrictions |
| |
| ---------------- |
| -- Check_Node -- |
| ---------------- |
| |
| function Check_Node (N : Node_Id) return Traverse_Result is |
| Kind : constant Node_Kind := Nkind (N); |
| |
| -- The following function belongs in sem_eval ??? |
| |
| function Is_Static_Function (Attr : Node_Id) return Boolean; |
| -- Given an attribute reference node Attr, return True if |
| -- Attr denotes a static function according to the rules in |
| -- (RM 4.9 (22)). |
| |
| ------------------------ |
| -- Is_Static_Function -- |
| ------------------------ |
| |
| function Is_Static_Function |
| (Attr : Node_Id) return Boolean |
| is |
| Para : Node_Id; |
| |
| begin |
| pragma Assert (Nkind (Attr) = N_Attribute_Reference); |
| |
| case Attribute_Name (Attr) is |
| when Name_Max |
| | Name_Min |
| | Name_Pred |
| | Name_Succ |
| | Name_Value |
| | Name_Wide_Value |
| | Name_Wide_Wide_Value |
| => |
| -- A language-defined attribute denotes a static |
| -- function if the prefix denotes a static scalar |
| -- subtype, and if the parameter and result types |
| -- are scalar (RM 4.9 (22)). |
| |
| if Is_Scalar_Type (Etype (Attr)) |
| and then Is_Scalar_Type (Etype (Prefix (Attr))) |
| and then |
| Is_OK_Static_Subtype (Etype (Prefix (Attr))) |
| then |
| Para := First (Expressions (Attr)); |
| |
| while Present (Para) loop |
| if not Is_Scalar_Type (Etype (Para)) then |
| return False; |
| end if; |
| |
| Next (Para); |
| end loop; |
| |
| return True; |
| |
| else |
| return False; |
| end if; |
| |
| when others => |
| return False; |
| end case; |
| end Is_Static_Function; |
| |
| -- Start of processing for Check_Node |
| |
| begin |
| if Is_Procedure then |
| -- Allocators restricted |
| |
| if Kind = N_Allocator then |
| if Lock_Free_Given then |
| Error_Msg_N ("allocator not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Aspects Address, Export and Import restricted |
| |
| elsif Kind = N_Aspect_Specification then |
| declare |
| Asp_Name : constant Name_Id := |
| Chars (Identifier (N)); |
| Asp_Id : constant Aspect_Id := |
| Get_Aspect_Id (Asp_Name); |
| |
| begin |
| if Asp_Id = Aspect_Address or else |
| Asp_Id = Aspect_Export or else |
| Asp_Id = Aspect_Import |
| then |
| Error_Msg_Name_1 := Asp_Name; |
| |
| if Lock_Free_Given then |
| Error_Msg_N ("aspect% not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end; |
| |
| -- Address attribute definition clause restricted |
| |
| elsif Kind = N_Attribute_Definition_Clause |
| and then Get_Attribute_Id (Chars (N)) = |
| Attribute_Address |
| then |
| Error_Msg_Name_1 := Chars (N); |
| |
| if Lock_Free_Given then |
| if From_Aspect_Specification (N) then |
| Error_Msg_N ("aspect% not allowed", N); |
| else |
| Error_Msg_N ("% clause not allowed", N); |
| end if; |
| |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Non-static Attribute references that don't denote a |
| -- static function restricted. |
| |
| elsif Kind = N_Attribute_Reference |
| and then not Is_OK_Static_Expression (N) |
| and then not Is_Static_Function (N) |
| then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("non-static attribute reference not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Delay statements restricted |
| |
| elsif Kind in N_Delay_Statement then |
| if Lock_Free_Given then |
| Error_Msg_N ("delay not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Dereferences of access values restricted |
| |
| elsif Kind = N_Explicit_Dereference |
| or else (Kind = N_Selected_Component |
| and then Is_Access_Type (Etype (Prefix (N)))) |
| then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("dereference of access value not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Non-static function calls restricted |
| |
| elsif Kind = N_Function_Call |
| and then not Is_OK_Static_Expression (N) |
| then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("non-static function call not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Goto statements restricted |
| |
| elsif Kind = N_Goto_Statement then |
| if Lock_Free_Given then |
| Error_Msg_N ("goto statement not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- References |
| |
| elsif Kind = N_Identifier |
| and then Present (Entity (N)) |
| then |
| declare |
| Id : constant Entity_Id := Entity (N); |
| Sub_Id : constant Entity_Id := |
| Corresponding_Spec (Sub_Body); |
| |
| begin |
| -- Prohibit references to non-constant entities |
| -- outside the protected subprogram scope. |
| |
| if Ekind (Id) in Assignable_Kind |
| and then not |
| Scope_Within_Or_Same (Scope (Id), Sub_Id) |
| and then not |
| Scope_Within_Or_Same |
| (Scope (Id), |
| Protected_Body_Subprogram (Sub_Id)) |
| then |
| if Lock_Free_Given then |
| Error_Msg_NE |
| ("reference to global variable& not " & |
| "allowed", N, Id); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end; |
| |
| -- Loop statements restricted |
| |
| elsif Kind = N_Loop_Statement then |
| if Lock_Free_Given then |
| Error_Msg_N ("loop not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Pragmas Export and Import restricted |
| |
| elsif Kind = N_Pragma then |
| declare |
| Prag_Name : constant Name_Id := |
| Pragma_Name (N); |
| Prag_Id : constant Pragma_Id := |
| Get_Pragma_Id (Prag_Name); |
| |
| begin |
| if Prag_Id = Pragma_Export |
| or else Prag_Id = Pragma_Import |
| then |
| Error_Msg_Name_1 := Prag_Name; |
| |
| if Lock_Free_Given then |
| if From_Aspect_Specification (N) then |
| Error_Msg_N ("aspect% not allowed", N); |
| else |
| Error_Msg_N ("pragma% not allowed", N); |
| end if; |
| |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end; |
| |
| -- Procedure call statements restricted |
| |
| elsif Kind = N_Procedure_Call_Statement then |
| if Lock_Free_Given then |
| Error_Msg_N ("procedure call not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| |
| -- Quantified expression restricted. Note that we have |
| -- to check the original node as well, since at this |
| -- stage, it may have been rewritten. |
| |
| elsif Kind = N_Quantified_Expression |
| or else |
| Nkind (Original_Node (N)) = N_Quantified_Expression |
| then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("quantified expression not allowed", N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end if; |
| |
| -- A protected subprogram (function or procedure) may |
| -- reference only one component of the protected type, plus |
| -- the type of the component must support atomic operation. |
| |
| if Kind = N_Identifier |
| and then Present (Entity (N)) |
| then |
| declare |
| Id : constant Entity_Id := Entity (N); |
| Comp_Decl : Node_Id; |
| Comp_Id : Entity_Id := Empty; |
| Comp_Type : Entity_Id; |
| |
| begin |
| if Ekind (Id) = E_Component then |
| Comp_Id := Id; |
| |
| elsif Ekind_In (Id, E_Constant, E_Variable) |
| and then Present (Prival_Link (Id)) |
| then |
| Comp_Id := Prival_Link (Id); |
| end if; |
| |
| if Present (Comp_Id) then |
| Comp_Decl := Parent (Comp_Id); |
| Comp_Type := Etype (Comp_Id); |
| |
| if Nkind (Comp_Decl) = N_Component_Declaration |
| and then Is_List_Member (Comp_Decl) |
| and then List_Containing (Comp_Decl) = Priv_Decls |
| then |
| -- Skip generic types since, in that case, we |
| -- will not build a body anyway (in the generic |
| -- template), and the size in the template may |
| -- have a fake value. |
| |
| if not Is_Generic_Type (Comp_Type) then |
| |
| -- Make sure the protected component type has |
| -- size and alignment fields set at this |
| -- point whenever this is possible. |
| |
| Layout_Type (Comp_Type); |
| |
| if not |
| Support_Atomic_Primitives (Comp_Type) |
| then |
| if Lock_Free_Given then |
| Error_Msg_NE |
| ("type of& must support atomic " & |
| "operations", |
| N, Comp_Id); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end if; |
| |
| -- Check if another protected component has |
| -- already been accessed by the subprogram body. |
| |
| if No (Comp) then |
| Comp := Comp_Id; |
| |
| elsif Comp /= Comp_Id then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("only one protected component allowed", |
| N); |
| return Skip; |
| end if; |
| |
| return Abandon; |
| end if; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| return OK; |
| end Check_Node; |
| |
| function Check_All_Nodes is new Traverse_Func (Check_Node); |
| |
| -- Start of processing for Satisfies_Lock_Free_Requirements |
| |
| begin |
| -- Get the number of errors detected by the compiler so far |
| |
| if Lock_Free_Given then |
| Errors_Count := Serious_Errors_Detected; |
| end if; |
| |
| if Check_All_Nodes (Sub_Body) = OK |
| and then (not Lock_Free_Given |
| or else Errors_Count = Serious_Errors_Detected) |
| then |
| -- Establish a relation between the subprogram body and the |
| -- unique protected component it references. |
| |
| if Present (Comp) then |
| Lock_Free_Subprogram_Table.Append |
| (Lock_Free_Subprogram'(Sub_Body, Comp)); |
| end if; |
| |
| return True; |
| else |
| return False; |
| end if; |
| end Satisfies_Lock_Free_Requirements; |
| |
| -- Start of processing for Protected_Body_Case |
| |
| begin |
| Decl := First (Decls); |
| while Present (Decl) loop |
| if Nkind (Decl) = N_Subprogram_Body |
| and then not Satisfies_Lock_Free_Requirements (Decl) |
| then |
| if Lock_Free_Given then |
| Error_Msg_N |
| ("illegal body when Lock_Free given", Decl); |
| else |
| return False; |
| end if; |
| end if; |
| |
| Next (Decl); |
| end loop; |
| end Protected_Body_Case; |
| end if; |
| |
| -- When Lock_Free is given, check if no error has been detected during |
| -- the process. |
| |
| if Lock_Free_Given |
| and then Errors_Count /= Serious_Errors_Detected |
| then |
| return False; |
| end if; |
| |
| return True; |
| end Allows_Lock_Free_Implementation; |
| |
| ----------------------------- |
| -- Analyze_Abort_Statement -- |
| ----------------------------- |
| |
| procedure Analyze_Abort_Statement (N : Node_Id) is |
| T_Name : Node_Id; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("abort statement is not allowed", N); |
| |
| T_Name := First (Names (N)); |
| while Present (T_Name) loop |
| Analyze (T_Name); |
| |
| if Is_Task_Type (Etype (T_Name)) |
| or else (Ada_Version >= Ada_2005 |
| and then Ekind (Etype (T_Name)) = E_Class_Wide_Type |
| and then Is_Interface (Etype (T_Name)) |
| and then Is_Task_Interface (Etype (T_Name))) |
| then |
| Resolve (T_Name); |
| else |
| if Ada_Version >= Ada_2005 then |
| Error_Msg_N ("expect task name or task interface class-wide " |
| & "object for ABORT", T_Name); |
| else |
| Error_Msg_N ("expect task name for ABORT", T_Name); |
| end if; |
| |
| return; |
| end if; |
| |
| Next (T_Name); |
| end loop; |
| |
| Check_Restriction (No_Abort_Statements, N); |
| Check_Potentially_Blocking_Operation (N); |
| end Analyze_Abort_Statement; |
| |
| -------------------------------- |
| -- Analyze_Accept_Alternative -- |
| -------------------------------- |
| |
| procedure Analyze_Accept_Alternative (N : Node_Id) is |
| begin |
| Tasking_Used := True; |
| |
| if Present (Pragmas_Before (N)) then |
| Analyze_List (Pragmas_Before (N)); |
| end if; |
| |
| if Present (Condition (N)) then |
| Analyze_And_Resolve (Condition (N), Any_Boolean); |
| end if; |
| |
| Analyze (Accept_Statement (N)); |
| |
| if Is_Non_Empty_List (Statements (N)) then |
| Analyze_Statements (Statements (N)); |
| end if; |
| end Analyze_Accept_Alternative; |
| |
| ------------------------------ |
| -- Analyze_Accept_Statement -- |
| ------------------------------ |
| |
| procedure Analyze_Accept_Statement (N : Node_Id) is |
| Nam : constant Entity_Id := Entry_Direct_Name (N); |
| Formals : constant List_Id := Parameter_Specifications (N); |
| Index : constant Node_Id := Entry_Index (N); |
| Stats : constant Node_Id := Handled_Statement_Sequence (N); |
| Accept_Id : Entity_Id; |
| Entry_Nam : Entity_Id; |
| E : Entity_Id; |
| Kind : Entity_Kind; |
| Task_Nam : Entity_Id := Empty; -- initialize to prevent warning |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("accept statement is not allowed", N); |
| |
| -- Entry name is initialized to Any_Id. It should get reset to the |
| -- matching entry entity. An error is signalled if it is not reset. |
| |
| Entry_Nam := Any_Id; |
| |
| for J in reverse 0 .. Scope_Stack.Last loop |
| Task_Nam := Scope_Stack.Table (J).Entity; |
| exit when Ekind (Etype (Task_Nam)) = E_Task_Type; |
| Kind := Ekind (Task_Nam); |
| |
| if Kind /= E_Block and then Kind /= E_Loop |
| and then not Is_Entry (Task_Nam) |
| then |
| Error_Msg_N ("enclosing body of accept must be a task", N); |
| return; |
| end if; |
| end loop; |
| |
| if Ekind (Etype (Task_Nam)) /= E_Task_Type then |
| Error_Msg_N ("invalid context for accept statement", N); |
| return; |
| end if; |
| |
| -- In order to process the parameters, we create a defining identifier |
| -- that can be used as the name of the scope. The name of the accept |
| -- statement itself is not a defining identifier, and we cannot use |
| -- its name directly because the task may have any number of accept |
| -- statements for the same entry. |
| |
| if Present (Index) then |
| Accept_Id := New_Internal_Entity |
| (E_Entry_Family, Current_Scope, Sloc (N), 'E'); |
| else |
| Accept_Id := New_Internal_Entity |
| (E_Entry, Current_Scope, Sloc (N), 'E'); |
| end if; |
| |
| Set_Etype (Accept_Id, Standard_Void_Type); |
| Set_Accept_Address (Accept_Id, New_Elmt_List); |
| |
| if Present (Formals) then |
| Push_Scope (Accept_Id); |
| Process_Formals (Formals, N); |
| Create_Extra_Formals (Accept_Id); |
| End_Scope; |
| end if; |
| |
| -- 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); |
| |
| E := First_Entity (Etype (Task_Nam)); |
| while Present (E) loop |
| if Chars (E) = Chars (Nam) |
| and then (Ekind (E) = Ekind (Accept_Id)) |
| and then Type_Conformant (Accept_Id, E) |
| then |
| Entry_Nam := E; |
| exit; |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| if Entry_Nam = Any_Id then |
| Error_Msg_N ("no entry declaration matches accept statement", N); |
| return; |
| else |
| Set_Entity (Nam, Entry_Nam); |
| Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False); |
| 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). |
| |
| if Current_Scope /= Task_Nam then |
| declare |
| E1 : Entity_Id; |
| |
| begin |
| E1 := First_Entity (Current_Scope); |
| while Present (E1) loop |
| if Ekind (E1) = E_Procedure |
| and then Chars (E1) = Chars (Entry_Nam) |
| and then Type_Conformant (E1, Entry_Nam) |
| then |
| Error_Msg_N ("entry name is not visible", N); |
| end if; |
| |
| Next_Entity (E1); |
| end loop; |
| end; |
| end if; |
| |
| Set_Convention (Accept_Id, Convention (Entry_Nam)); |
| Check_Fully_Conformant (Accept_Id, Entry_Nam, N); |
| |
| for J in reverse 0 .. Scope_Stack.Last loop |
| exit when Task_Nam = Scope_Stack.Table (J).Entity; |
| |
| if Entry_Nam = Scope_Stack.Table (J).Entity then |
| Error_Msg_N ("duplicate accept statement for same entry", N); |
| end if; |
| end loop; |
| |
| declare |
| P : Node_Id := N; |
| begin |
| loop |
| P := Parent (P); |
| case Nkind (P) is |
| when N_Compilation_Unit |
| | N_Task_Body |
| => |
| exit; |
| |
| when N_Asynchronous_Select => |
| Error_Msg_N |
| ("accept statements are not allowed within an " |
| & "asynchronous select inner to the enclosing task body", |
| N); |
| exit; |
| |
| when others => |
| null; |
| end case; |
| end loop; |
| end; |
| |
| if Ekind (E) = E_Entry_Family then |
| if No (Index) then |
| Error_Msg_N ("missing entry index in accept for entry family", N); |
| else |
| Analyze_And_Resolve (Index, Entry_Index_Type (E)); |
| Apply_Range_Check (Index, Entry_Index_Type (E)); |
| end if; |
| |
| elsif Present (Index) then |
| 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 Present (Declarations (N)) then |
| declare |
| Decl : Node_Id; |
| Id : Entity_Id; |
| |
| begin |
| Decl := First (Declarations (N)); |
| while Present (Decl) loop |
| Analyze (Decl); |
| |
| pragma Assert |
| (Nkind (Decl) = N_Implicit_Label_Declaration); |
| |
| Id := Defining_Identifier (Decl); |
| Set_Enclosing_Scope (Id, Entry_Nam); |
| Next (Decl); |
| end loop; |
| 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. |
| |
| -- 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 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 Referenced, Referenced_As_xxx 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); |
| while Present (E) loop |
| if Is_Formal (E) then |
| Set_Never_Set_In_Source (E, True); |
| Set_Is_True_Constant (E, False); |
| Set_Current_Value (E, Empty); |
| Set_Referenced (E, False); |
| Set_Referenced_As_LHS (E, False); |
| Set_Referenced_As_Out_Parameter (E, False); |
| Set_Has_Pragma_Unreferenced (E, False); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| -- Analyze statements if present |
| |
| if Present (Stats) then |
| Push_Scope (Entry_Nam); |
| Install_Declarations (Entry_Nam); |
| |
| Set_Actual_Subtypes (N, Current_Scope); |
| |
| Analyze (Stats); |
| Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam); |
| End_Scope; |
| end if; |
| |
| -- Some warning checks |
| |
| Check_Potentially_Blocking_Operation (N); |
| Check_References (Entry_Nam, N); |
| Set_Entry_Accepted (Entry_Nam); |
| end Analyze_Accept_Statement; |
| |
| --------------------------------- |
| -- Analyze_Asynchronous_Select -- |
| --------------------------------- |
| |
| procedure Analyze_Asynchronous_Select (N : Node_Id) is |
| Is_Disp_Select : Boolean := False; |
| Trigger : Node_Id; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("select statement is not allowed", N); |
| Check_Restriction (Max_Asynchronous_Select_Nesting, N); |
| Check_Restriction (No_Select_Statements, N); |
| |
| if Ada_Version >= Ada_2005 then |
| Trigger := Triggering_Statement (Triggering_Alternative (N)); |
| |
| Analyze (Trigger); |
| |
| -- Ada 2005 (AI-345): Check for a potential dispatching select |
| |
| Check_Triggering_Statement (Trigger, N, Is_Disp_Select); |
| end if; |
| |
| -- Ada 2005 (AI-345): The expansion of the dispatching asynchronous |
| -- select will have to duplicate the triggering statements. Postpone |
| -- the analysis of the statements till expansion. Analyze only if the |
| -- expander is disabled in order to catch any semantic errors. |
| |
| if Is_Disp_Select then |
| if not Expander_Active then |
| Analyze_Statements (Statements (Abortable_Part (N))); |
| Analyze (Triggering_Alternative (N)); |
| end if; |
| |
| -- Analyze the statements. We analyze statements in the abortable part, |
| -- because this is the section that is executed first, and that way our |
| -- remembering of saved values and checks is accurate. |
| |
| else |
| Analyze_Statements (Statements (Abortable_Part (N))); |
| Analyze (Triggering_Alternative (N)); |
| end if; |
| end Analyze_Asynchronous_Select; |
| |
| ------------------------------------ |
| -- Analyze_Conditional_Entry_Call -- |
| ------------------------------------ |
| |
| procedure Analyze_Conditional_Entry_Call (N : Node_Id) is |
| Trigger : constant Node_Id := |
| Entry_Call_Statement (Entry_Call_Alternative (N)); |
| Is_Disp_Select : Boolean := False; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("select statement is not allowed", N); |
| Check_Restriction (No_Select_Statements, N); |
| |
| -- Ada 2005 (AI-345): The trigger may be a dispatching call |
| |
| if Ada_Version >= Ada_2005 then |
| Analyze (Trigger); |
| Check_Triggering_Statement (Trigger, N, Is_Disp_Select); |
| end if; |
| |
| if List_Length (Else_Statements (N)) = 1 |
| and then Nkind (First (Else_Statements (N))) in N_Delay_Statement |
| then |
| Error_Msg_N |
| ("suspicious form of conditional entry call??!", N); |
| Error_Msg_N |
| ("\`SELECT OR` may be intended rather than `SELECT ELSE`??!", N); |
| end if; |
| |
| -- Postpone the analysis of the statements till expansion. Analyze only |
| -- if the expander is disabled in order to catch any semantic errors. |
| |
| if Is_Disp_Select then |
| if not Expander_Active then |
| Analyze (Entry_Call_Alternative (N)); |
| Analyze_Statements (Else_Statements (N)); |
| end if; |
| |
| -- Regular select analysis |
| |
| else |
| Analyze (Entry_Call_Alternative (N)); |
| Analyze_Statements (Else_Statements (N)); |
| end if; |
| end Analyze_Conditional_Entry_Call; |
| |
| -------------------------------- |
| -- Analyze_Delay_Alternative -- |
| -------------------------------- |
| |
| procedure Analyze_Delay_Alternative (N : Node_Id) is |
| Expr : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| Tasking_Used := True; |
| Check_Restriction (No_Delay, N); |
| |
| if Present (Pragmas_Before (N)) then |
| Analyze_List (Pragmas_Before (N)); |
| end if; |
| |
| if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then |
| Expr := Expression (Delay_Statement (N)); |
| |
| -- 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. |
| |
| if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then |
| Preanalyze_And_Resolve (Expr, Standard_Duration); |
| else |
| Preanalyze_And_Resolve (Expr); |
| end if; |
| |
| Typ := First_Subtype (Etype (Expr)); |
| |
| if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement |
| and then not Is_RTE (Typ, RO_CA_Time) |
| and then not Is_RTE (Typ, RO_RT_Time) |
| then |
| Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr); |
| end if; |
| |
| Check_Restriction (No_Fixed_Point, Expr); |
| |
| else |
| Analyze (Delay_Statement (N)); |
| end if; |
| |
| if Present (Condition (N)) then |
| Analyze_And_Resolve (Condition (N), Any_Boolean); |
| end if; |
| |
| if Is_Non_Empty_List (Statements (N)) then |
| Analyze_Statements (Statements (N)); |
| end if; |
| end Analyze_Delay_Alternative; |
| |
| ---------------------------- |
| -- Analyze_Delay_Relative -- |
| ---------------------------- |
| |
| procedure Analyze_Delay_Relative (N : Node_Id) is |
| E : constant Node_Id := Expression (N); |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("delay statement is not allowed", N); |
| Check_Restriction (No_Relative_Delay, N); |
| Check_Restriction (No_Delay, N); |
| Check_Potentially_Blocking_Operation (N); |
| Analyze_And_Resolve (E, Standard_Duration); |
| Check_Restriction (No_Fixed_Point, E); |
| |
| -- In SPARK mode the relative delay statement introduces an implicit |
| -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must |
| -- force the loading of the Ada.Real_Time package. |
| |
| if GNATprove_Mode then |
| SPARK_Implicit_Load (RO_RT_Time); |
| end if; |
| end Analyze_Delay_Relative; |
| |
| ------------------------- |
| -- Analyze_Delay_Until -- |
| ------------------------- |
| |
| procedure Analyze_Delay_Until (N : Node_Id) is |
| E : constant Node_Id := Expression (N); |
| Typ : Entity_Id; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("delay statement is not allowed", N); |
| Check_Restriction (No_Delay, N); |
| Check_Potentially_Blocking_Operation (N); |
| Analyze_And_Resolve (E); |
| Typ := First_Subtype (Etype (E)); |
| |
| if not Is_RTE (Typ, RO_CA_Time) and then |
| not Is_RTE (Typ, RO_RT_Time) |
| then |
| Error_Msg_N ("expect Time types for `DELAY UNTIL`", E); |
| end if; |
| end Analyze_Delay_Until; |
| |
| ------------------------ |
| -- Analyze_Entry_Body -- |
| ------------------------ |
| |
| procedure Analyze_Entry_Body (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (N); |
| Decls : constant List_Id := Declarations (N); |
| Stats : constant Node_Id := Handled_Statement_Sequence (N); |
| Formals : constant Node_Id := Entry_Body_Formal_Part (N); |
| P_Type : constant Entity_Id := Current_Scope; |
| E : Entity_Id; |
| Entry_Name : Entity_Id; |
| |
| begin |
| -- An entry body freezes the contract of the nearest enclosing package |
| -- body and all other contracts encountered in the same declarative part |
| -- up to and excluding the entry body. This ensures that any annotations |
| -- referenced by the contract of an entry or subprogram body declared |
| -- within the current protected body are available. |
| |
| Freeze_Previous_Contracts (N); |
| |
| Tasking_Used := True; |
| |
| -- Entry_Name is initialized to Any_Id. It should get reset to the |
| -- matching entry entity. An error is signalled if it is not reset. |
| |
| Entry_Name := Any_Id; |
| |
| Analyze (Formals); |
| |
| if Present (Entry_Index_Specification (Formals)) then |
| Set_Ekind (Id, E_Entry_Family); |
| else |
| Set_Ekind (Id, E_Entry); |
| end if; |
| |
| Set_Etype (Id, Standard_Void_Type); |
| Set_Scope (Id, Current_Scope); |
| Set_Accept_Address (Id, New_Elmt_List); |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with an explicit pragma). |
| |
| Set_SPARK_Pragma (Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Id); |
| |
| -- Analyze any aspect specifications that appear on the entry body |
| |
| if Has_Aspects (N) then |
| Analyze_Aspects_On_Subprogram_Body_Or_Stub (N); |
| end if; |
| |
| E := First_Entity (P_Type); |
| while Present (E) loop |
| if Chars (E) = Chars (Id) |
| and then (Ekind (E) = Ekind (Id)) |
| and then Type_Conformant (Id, E) |
| then |
| Entry_Name := E; |
| Set_Convention (Id, Convention (E)); |
| Set_Corresponding_Body (Parent (E), Id); |
| Check_Fully_Conformant (Id, E, N); |
| |
| if Ekind (Id) = E_Entry_Family then |
| if not Fully_Conformant_Discrete_Subtypes ( |
| Discrete_Subtype_Definition (Parent (E)), |
| Discrete_Subtype_Definition |
| (Entry_Index_Specification (Formals))) |
| then |
| Error_Msg_N |
| ("index not fully conformant with previous declaration", |
| Discrete_Subtype_Definition |
| (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. |
| |
| declare |
| Index_Spec : constant Node_Id := |
| Entry_Index_Specification (Formals); |
| |
| Def : constant Node_Id := |
| New_Copy_Tree |
| (Discrete_Subtype_Definition (Parent (E))); |
| |
| begin |
| if Nkind |
| (Original_Node |
| (Discrete_Subtype_Definition (Index_Spec))) = N_Range |
| then |
| Set_Etype (Def, Empty); |
| Set_Analyzed (Def, False); |
| |
| -- Keep the original subtree to ensure a properly |
| -- formed tree (e.g. for ASIS use). |
| |
| Rewrite |
| (Discrete_Subtype_Definition (Index_Spec), Def); |
| |
| Set_Analyzed (Low_Bound (Def), False); |
| Set_Analyzed (High_Bound (Def), False); |
| |
| if Denotes_Discriminant (Low_Bound (Def)) then |
| Set_Entity (Low_Bound (Def), Empty); |
| end if; |
| |
| if Denotes_Discriminant (High_Bound (Def)) then |
| Set_Entity (High_Bound (Def), Empty); |
| end if; |
| |
| Analyze (Def); |
| Make_Index (Def, Index_Spec); |
| Set_Etype |
| (Defining_Identifier (Index_Spec), Etype (Def)); |
| end if; |
| end; |
| end if; |
| end if; |
| |
| exit; |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| if Entry_Name = Any_Id then |
| Error_Msg_N ("no entry declaration matches entry body", N); |
| return; |
| |
| elsif Has_Completion (Entry_Name) then |
| Error_Msg_N ("duplicate entry body", N); |
| return; |
| |
| else |
| Set_Has_Completion (Entry_Name); |
| Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False); |
| Style.Check_Identifier (Id, Entry_Name); |
| end if; |
| |
| Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); |
| Push_Scope (Entry_Name); |
| |
| Install_Declarations (Entry_Name); |
| Set_Actual_Subtypes (N, Current_Scope); |
| |
| -- The entity for the protected subprogram corresponding to the entry |
| -- has been created. We retain the name of this entity in the entry |
| -- body, for use when the corresponding subprogram body is created. |
| -- Note that entry bodies have no Corresponding_Spec, and there is no |
| -- easy link back in the tree between the entry body and the entity for |
| -- the entry itself, which is why we must propagate some attributes |
| -- explicitly from spec to body. |
| |
| Set_Protected_Body_Subprogram |
| (Id, Protected_Body_Subprogram (Entry_Name)); |
| |
| Set_Entry_Parameters_Type |
| (Id, Entry_Parameters_Type (Entry_Name)); |
| |
| -- Add a declaration for the Protection object, renaming declarations |
| -- for the discriminals and privals and finally a declaration for the |
| -- entry family index (if applicable). |
| |
| if Expander_Active |
| and then Is_Protected_Type (P_Type) |
| then |
| Install_Private_Data_Declarations |
| (Sloc (N), Entry_Name, P_Type, N, Decls); |
| end if; |
| |
| if Present (Decls) then |
| Analyze_Declarations (Decls); |
| Inspect_Deferred_Constant_Completion (Decls); |
| end if; |
| |
| -- Process the contract of the subprogram body after all declarations |
| -- have been analyzed. This ensures that any contract-related pragmas |
| -- are available through the N_Contract node of the body. |
| |
| Analyze_Entry_Or_Subprogram_Body_Contract (Id); |
| |
| if Present (Stats) then |
| Analyze (Stats); |
| end if; |
| |
| -- Check for unreferenced variables etc. Before the Check_References |
| -- call, we transfer Never_Set_In_Source and Referenced flags from |
| -- parameters in the spec to the corresponding entities in the body, |
| -- since we want the warnings on the body entities. Note that we do not |
| -- have to transfer Referenced_As_LHS, since that flag can only be set |
| -- for simple variables, but we include Has_Pragma_Unreferenced, |
| -- which may have been specified for a formal in the body. |
| |
| -- At the same time, we set the flags on the spec entities to suppress |
| -- any warnings on the spec formals, since we also scan the spec. |
| -- Finally, we propagate the Entry_Component attribute to the body |
| -- formals, for use in the renaming declarations created later for the |
| -- formals (see exp_ch9.Add_Formal_Renamings). |
| |
| declare |
| E1 : Entity_Id; |
| E2 : Entity_Id; |
| |
| begin |
| E1 := First_Entity (Entry_Name); |
| while Present (E1) loop |
| E2 := First_Entity (Id); |
| while Present (E2) loop |
| exit when Chars (E1) = Chars (E2); |
| Next_Entity (E2); |
| end loop; |
| |
| -- If no matching body entity, then we already had a detected |
| -- error of some kind, so just don't worry about these warnings. |
| |
| if No (E2) then |
| goto Continue; |
| end if; |
| |
| if Ekind (E1) = E_Out_Parameter then |
| Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1)); |
| Set_Never_Set_In_Source (E1, False); |
| end if; |
| |
| Set_Referenced (E2, Referenced (E1)); |
| Set_Referenced (E1); |
| Set_Has_Pragma_Unreferenced (E2, Has_Pragma_Unreferenced (E1)); |
| Set_Entry_Component (E2, Entry_Component (E1)); |
| |
| <<Continue>> |
| Next_Entity (E1); |
| end loop; |
| |
| Check_References (Id); |
| end; |
| |
| -- We still need to check references for the spec, since objects |
| -- declared in the body are chained (in the First_Entity sense) to |
| -- the spec rather than the body in the case of entries. |
| |
| Check_References (Entry_Name); |
| |
| -- Process the end label, and terminate the scope |
| |
| Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); |
| Update_Use_Clause_Chain; |
| End_Scope; |
| |
| -- If this is an entry family, remove the loop created to provide |
| -- a scope for the entry index. |
| |
| if Ekind (Id) = E_Entry_Family |
| and then Present (Entry_Index_Specification (Formals)) |
| then |
| End_Scope; |
| end if; |
| end Analyze_Entry_Body; |
| |
| ------------------------------------ |
| -- Analyze_Entry_Body_Formal_Part -- |
| ------------------------------------ |
| |
| procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is |
| Id : constant Entity_Id := Defining_Identifier (Parent (N)); |
| Index : constant Node_Id := Entry_Index_Specification (N); |
| Formals : constant List_Id := Parameter_Specifications (N); |
| |
| begin |
| Tasking_Used := True; |
| |
| if Present (Index) then |
| Analyze (Index); |
| |
| -- The entry index functions like a loop variable, thus it is known |
| -- to have a valid value. |
| |
| Set_Is_Known_Valid (Defining_Identifier (Index)); |
| end if; |
| |
| if Present (Formals) then |
| Set_Scope (Id, Current_Scope); |
| Push_Scope (Id); |
| Process_Formals (Formals, Parent (N)); |
| End_Scope; |
| end if; |
| end Analyze_Entry_Body_Formal_Part; |
| |
| ------------------------------------ |
| -- Analyze_Entry_Call_Alternative -- |
| ------------------------------------ |
| |
| procedure Analyze_Entry_Call_Alternative (N : Node_Id) is |
| Call : constant Node_Id := Entry_Call_Statement (N); |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("entry call is not allowed", N); |
| |
| if Present (Pragmas_Before (N)) then |
| Analyze_List (Pragmas_Before (N)); |
| end if; |
| |
| if Nkind (Call) = N_Attribute_Reference then |
| |
| -- Possibly a stream attribute, but definitely illegal. Other |
| -- illegalities, such as procedure calls, are diagnosed after |
| -- resolution. |
| |
| Error_Msg_N ("entry call alternative requires an entry call", Call); |
| return; |
| end if; |
| |
| Analyze (Call); |
| |
| -- An indirect call in this context is illegal. A procedure call that |
| -- does not involve a renaming of an entry is illegal as well, but this |
| -- and other semantic errors are caught during resolution. |
| |
| if Nkind (Call) = N_Explicit_Dereference then |
| Error_Msg_N |
| ("entry call or dispatching primitive of interface required ", N); |
| end if; |
| |
| if Is_Non_Empty_List (Statements (N)) then |
| Analyze_Statements (Statements (N)); |
| end if; |
| end Analyze_Entry_Call_Alternative; |
| |
| ------------------------------- |
| -- Analyze_Entry_Declaration -- |
| ------------------------------- |
| |
| procedure Analyze_Entry_Declaration (N : Node_Id) is |
| D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N); |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| Formals : constant List_Id := Parameter_Specifications (N); |
| |
| begin |
| Generate_Definition (Def_Id); |
| |
| Tasking_Used := True; |
| |
| -- Case of no discrete subtype definition |
| |
| if No (D_Sdef) then |
| Set_Ekind (Def_Id, E_Entry); |
| |
| -- Processing for discrete subtype definition present |
| |
| else |
| Enter_Name (Def_Id); |
| Set_Ekind (Def_Id, E_Entry_Family); |
| Analyze (D_Sdef); |
| Make_Index (D_Sdef, N, Def_Id); |
| |
| -- Check subtype with predicate in entry family |
| |
| Bad_Predicated_Subtype_Use |
| ("subtype& has predicate, not allowed in entry family", |
| D_Sdef, Etype (D_Sdef)); |
| |
| -- Check entry family static bounds outside allowed limits |
| |
| -- Note: originally this check was not performed here, but in that |
| -- case the check happens deep in the expander, and the message is |
| -- posted at the wrong location, and omitted in -gnatc mode. |
| -- If the type of the entry index is a generic formal, no check |
| -- is possible. In an instance, the check is not static and a run- |
| -- time exception will be raised if the bounds are unreasonable. |
| |
| declare |
| PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); |
| LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); |
| UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); |
| |
| LBR : Node_Id; |
| UBR : Node_Id; |
| |
| begin |
| |
| -- No bounds checking if the type is generic or if previous error. |
| -- In an instance the check is dynamic. |
| |
| if Is_Generic_Type (Etype (D_Sdef)) |
| or else In_Instance |
| or else Error_Posted (D_Sdef) |
| then |
| goto Skip_LB; |
| |
| elsif Nkind (D_Sdef) = N_Range then |
| LBR := Low_Bound (D_Sdef); |
| |
| elsif Is_Entity_Name (D_Sdef) |
| and then Is_Type (Entity (D_Sdef)) |
| then |
| LBR := Type_Low_Bound (Entity (D_Sdef)); |
| |
| else |
| goto Skip_LB; |
| end if; |
| |
| if Is_OK_Static_Expression (LBR) |
| and then Expr_Value (LBR) < LB |
| then |
| Error_Msg_Uint_1 := LB; |
| Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); |
| end if; |
| |
| <<Skip_LB>> |
| if Is_Generic_Type (Etype (D_Sdef)) |
| or else In_Instance |
| or else Error_Posted (D_Sdef) |
| then |
| goto Skip_UB; |
| |
| elsif Nkind (D_Sdef) = N_Range then |
| UBR := High_Bound (D_Sdef); |
| |
| elsif Is_Entity_Name (D_Sdef) |
| and then Is_Type (Entity (D_Sdef)) |
| then |
| UBR := Type_High_Bound (Entity (D_Sdef)); |
| |
| else |
| goto Skip_UB; |
| end if; |
| |
| if Is_OK_Static_Expression (UBR) |
| and then Expr_Value (UBR) > UB |
| then |
| Error_Msg_Uint_1 := UB; |
| Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); |
| end if; |
| |
| <<Skip_UB>> |
| null; |
| end; |
| end if; |
| |
| -- Decorate Def_Id |
| |
| Set_Etype (Def_Id, Standard_Void_Type); |
| Set_Convention (Def_Id, Convention_Entry); |
| Set_Accept_Address (Def_Id, New_Elmt_List); |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with an explicit pragma). Task entries are excluded because they are |
| -- not completed by entry bodies. |
| |
| if Ekind (Current_Scope) = E_Protected_Type then |
| Set_SPARK_Pragma (Def_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Def_Id); |
| end if; |
| |
| -- Preserve relevant elaboration-related attributes of the context which |
| -- are no longer available or very expensive to recompute once analysis, |
| -- resolution, and expansion are over. |
| |
| Mark_Elaboration_Attributes |
| (N_Id => Def_Id, |
| Checks => True, |
| Warnings => True); |
| |
| -- Process formals |
| |
| if Present (Formals) then |
| Set_Scope (Def_Id, Current_Scope); |
| Push_Scope (Def_Id); |
| Process_Formals (Formals, N); |
| Create_Extra_Formals (Def_Id); |
| End_Scope; |
| end if; |
| |
| if Ekind (Def_Id) = E_Entry then |
| New_Overloaded_Entity (Def_Id); |
| end if; |
| |
| Generate_Reference_To_Formals (Def_Id); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Def_Id); |
| end if; |
| end Analyze_Entry_Declaration; |
| |
| --------------------------------------- |
| -- Analyze_Entry_Index_Specification -- |
| --------------------------------------- |
| |
| -- 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 its 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 known to routines |
| -- that process entry families. |
| |
| procedure Analyze_Entry_Index_Specification (N : Node_Id) is |
| Iden : constant Node_Id := Defining_Identifier (N); |
| Def : constant Node_Id := Discrete_Subtype_Definition (N); |
| Loop_Id : constant Entity_Id := Make_Temporary (Sloc (N), 'L'); |
| |
| begin |
| Tasking_Used := True; |
| Analyze (Def); |
| |
| -- There is no elaboration of the entry index specification. Therefore, |
| -- if the index is a range, it is not resolved and expanded, but the |
| -- bounds are inherited from the entry declaration, and reanalyzed. |
| -- See Analyze_Entry_Body. |
| |
| if Nkind (Def) /= N_Range then |
| Make_Index (Def, N); |
| end if; |
| |
| Set_Ekind (Loop_Id, E_Loop); |
| Set_Scope (Loop_Id, Current_Scope); |
| Push_Scope (Loop_Id); |
| Enter_Name (Iden); |
| Set_Ekind (Iden, E_Entry_Index_Parameter); |
| Set_Etype (Iden, Etype (Def)); |
| end Analyze_Entry_Index_Specification; |
| |
| ---------------------------- |
| -- Analyze_Protected_Body -- |
| ---------------------------- |
| |
| procedure Analyze_Protected_Body (N : Node_Id) is |
| 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 |
| -- type involved, but is replaced by the protected type always in the |
| -- case of a single protected declaration, since this is the proper |
| -- scope to be used. |
| |
| Ref_Id : Entity_Id; |
| -- This is the entity of the protected object or protected type |
| -- involved, and is the entity used for cross-reference purposes (it |
| -- differs from Spec_Id in the case of a single protected object, since |
| -- Spec_Id is set to the protected type in this case). |
| |
| function Lock_Free_Disabled return Boolean; |
| -- This routine returns False if the protected object has a Lock_Free |
| -- aspect specification or a Lock_Free pragma that turns off the |
| -- lock-free implementation (e.g. whose expression is False). |
| |
| ------------------------ |
| -- Lock_Free_Disabled -- |
| ------------------------ |
| |
| function Lock_Free_Disabled return Boolean is |
| Ritem : constant Node_Id := |
| Get_Rep_Item |
| (Spec_Id, Name_Lock_Free, Check_Parents => False); |
| |
| begin |
| if Present (Ritem) then |
| |
| -- Pragma with one argument |
| |
| if Nkind (Ritem) = N_Pragma |
| and then Present (Pragma_Argument_Associations (Ritem)) |
| then |
| return |
| Is_False |
| (Static_Boolean |
| (Expression |
| (First (Pragma_Argument_Associations (Ritem))))); |
| |
| -- Aspect Specification with expression present |
| |
| elsif Nkind (Ritem) = N_Aspect_Specification |
| and then Present (Expression (Ritem)) |
| then |
| return Is_False (Static_Boolean (Expression (Ritem))); |
| |
| -- Otherwise, return False |
| |
| else |
| return False; |
| end if; |
| end if; |
| |
| return False; |
| end Lock_Free_Disabled; |
| |
| -- Start of processing for Analyze_Protected_Body |
| |
| begin |
| -- A protected body freezes the contract of the nearest enclosing |
| -- package body and all other contracts encountered in the same |
| -- declarative part up to and excluding the protected body. This |
| -- ensures that any annotations referenced by the contract of an |
| -- entry or subprogram body declared within the current protected |
| -- body are available. |
| |
| Freeze_Previous_Contracts (N); |
| |
| Tasking_Used := True; |
| Set_Ekind (Body_Id, E_Protected_Body); |
| Set_Etype (Body_Id, Standard_Void_Type); |
| Spec_Id := Find_Concurrent_Spec (Body_Id); |
| |
| if Present (Spec_Id) and then Ekind (Spec_Id) = E_Protected_Type then |
| null; |
| |
| elsif Present (Spec_Id) |
| and then Ekind (Etype (Spec_Id)) = E_Protected_Type |
| and then not Comes_From_Source (Etype (Spec_Id)) |
| then |
| null; |
| |
| else |
| Error_Msg_N ("missing specification for protected body", Body_Id); |
| return; |
| end if; |
| |
| Ref_Id := Spec_Id; |
| Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); |
| Style.Check_Identifier (Body_Id, Spec_Id); |
| |
| -- The declarations are always attached to the type |
| |
| if Ekind (Spec_Id) /= E_Protected_Type then |
| Spec_Id := Etype (Spec_Id); |
| end if; |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Body_Id); |
| end if; |
| |
| Push_Scope (Spec_Id); |
| Set_Corresponding_Spec (N, Spec_Id); |
| Set_Corresponding_Body (Parent (Spec_Id), Body_Id); |
| Set_Has_Completion (Spec_Id); |
| Install_Declarations (Spec_Id); |
| Expand_Protected_Body_Declarations (N, Spec_Id); |
| Last_E := Last_Entity (Spec_Id); |
| |
| 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. |
| |
| if No (First_Private_Entity (Spec_Id)) then |
| if Present (Last_E) then |
| Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); |
| else |
| Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); |
| end if; |
| end if; |
| |
| Check_Completion (Body_Id); |
| Check_References (Spec_Id); |
| Process_End_Label (N, 't', Ref_Id); |
| Update_Use_Clause_Chain; |
| End_Scope; |
| |
| -- When a Lock_Free aspect specification/pragma forces the lock-free |
| -- implementation, verify the protected body meets all the restrictions, |
| -- otherwise Allows_Lock_Free_Implementation issues an error message. |
| |
| if Uses_Lock_Free (Spec_Id) then |
| if not Allows_Lock_Free_Implementation (N, True) then |
| return; |
| end if; |
| |
| -- In other cases, if there is no aspect specification/pragma that |
| -- disables the lock-free implementation, check both the protected |
| -- declaration and body satisfy the lock-free restrictions. |
| |
| elsif not Lock_Free_Disabled |
| and then Allows_Lock_Free_Implementation (Parent (Spec_Id)) |
| and then Allows_Lock_Free_Implementation (N) |
| then |
| Set_Uses_Lock_Free (Spec_Id); |
| end if; |
| end Analyze_Protected_Body; |
| |
| ---------------------------------- |
| -- Analyze_Protected_Definition -- |
| ---------------------------------- |
| |
| procedure Analyze_Protected_Definition (N : Node_Id) is |
| E : Entity_Id; |
| L : Entity_Id; |
| |
| procedure Undelay_Itypes (T : Entity_Id); |
| -- Itypes created for the private components of a protected type |
| -- do not receive freeze nodes, because there is no scope in which |
| -- they can be elaborated, and they can depend on discriminants of |
| -- the enclosed protected type. Given that the components can be |
| -- composite types with inner components, we traverse recursively |
| -- the private components of the protected type, and indicate that |
| -- all itypes within are frozen. This ensures that no freeze nodes |
| -- will be generated for them. In the case of itypes that are access |
| -- types we need to complete their representation by calling layout, |
| -- which would otherwise be invoked when freezing a type. |
| -- |
| -- On the other hand, components of the corresponding record are |
| -- frozen (or receive itype references) as for other records. |
| |
| -------------------- |
| -- Undelay_Itypes -- |
| -------------------- |
| |
| procedure Undelay_Itypes (T : Entity_Id) is |
| Comp : Entity_Id; |
| |
| begin |
| if Is_Protected_Type (T) then |
| Comp := First_Private_Entity (T); |
| elsif Is_Record_Type (T) then |
| Comp := First_Entity (T); |
| else |
| return; |
| end if; |
| |
| while Present (Comp) loop |
| if Is_Type (Comp) |
| and then Is_Itype (Comp) |
| then |
| Set_Has_Delayed_Freeze (Comp, False); |
| Set_Is_Frozen (Comp); |
| |
| if Is_Access_Type (Comp) then |
| Layout_Type (Comp); |
| end if; |
| |
| if Is_Record_Type (Comp) |
| or else Is_Protected_Type (Comp) |
| then |
| Undelay_Itypes (Comp); |
| end if; |
| end if; |
| |
| Next_Entity (Comp); |
| end loop; |
| end Undelay_Itypes; |
| |
| -- Start of processing for Analyze_Protected_Definition |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("protected definition is not allowed", N); |
| Analyze_Declarations (Visible_Declarations (N)); |
| |
| if Present (Private_Declarations (N)) |
| and then not Is_Empty_List (Private_Declarations (N)) |
| then |
| L := Last_Entity (Current_Scope); |
| Analyze_Declarations (Private_Declarations (N)); |
| |
| if Present (L) then |
| Set_First_Private_Entity (Current_Scope, Next_Entity (L)); |
| else |
| Set_First_Private_Entity (Current_Scope, |
| First_Entity (Current_Scope)); |
| end if; |
| end if; |
| |
| E := First_Entity (Current_Scope); |
| while Present (E) loop |
| if Ekind_In (E, E_Function, E_Procedure) then |
| Set_Convention (E, Convention_Protected); |
| else |
| Propagate_Concurrent_Flags (Current_Scope, Etype (E)); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| Undelay_Itypes (Current_Scope); |
| |
| Check_Max_Entries (N, Max_Protected_Entries); |
| Process_End_Label (N, 'e', Current_Scope); |
| end Analyze_Protected_Definition; |
| |
| ---------------------------------------- |
| -- Analyze_Protected_Type_Declaration -- |
| ---------------------------------------- |
| |
| procedure Analyze_Protected_Type_Declaration (N : Node_Id) is |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| E : Entity_Id; |
| T : Entity_Id; |
| |
| begin |
| if No_Run_Time_Mode then |
| Error_Msg_CRT ("protected type", N); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Def_Id); |
| end if; |
| |
| return; |
| end if; |
| |
| Tasking_Used := True; |
| Check_Restriction (No_Protected_Types, N); |
| |
| T := Find_Type_Name (N); |
| |
| -- In the case of an incomplete type, use the full view, unless it's not |
| -- present (as can occur for an incomplete view from a limited with). |
| |
| if Ekind (T) = E_Incomplete_Type and then Present (Full_View (T)) then |
| T := Full_View (T); |
| Set_Completion_Referenced (T); |
| end if; |
| |
| Set_Ekind (T, E_Protected_Type); |
| Set_Is_First_Subtype (T); |
| Init_Size_Align (T); |
| Set_Etype (T, T); |
| Set_Has_Delayed_Freeze (T); |
| Set_Stored_Constraint (T, No_Elist); |
| |
| -- Mark this type as a protected type for the sake of restrictions, |
| -- unless the protected type is declared in a private part of a package |
| -- of the runtime. With this exception, the Suspension_Object from |
| -- Ada.Synchronous_Task_Control can be implemented using a protected |
| -- object without triggering violations of No_Local_Protected_Objects |
| -- when the user locally declares such an object. This may look like a |
| -- trick, but the user doesn't have to know how Suspension_Object is |
| -- implemented. |
| |
| if In_Private_Part (Current_Scope) |
| and then Is_Internal_Unit (Current_Sem_Unit) |
| then |
| Set_Has_Protected (T, False); |
| else |
| Set_Has_Protected (T); |
| end if; |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with an explicit pragma). |
| |
| Set_SPARK_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (T); |
| Set_SPARK_Aux_Pragma_Inherited (T); |
| |
| Push_Scope (T); |
| |
| if Ada_Version >= Ada_2005 then |
| Check_Interfaces (N, T); |
| 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. ??? |
| |
| Install_Declarations (T); |
| else |
| Process_Discriminants (N); |
| end if; |
| end if; |
| |
| Set_Is_Constrained (T, not Has_Discriminants (T)); |
| |
| -- If aspects are present, analyze them now. They can make references to |
| -- the discriminants of the type, but not to any components. |
| |
| if Has_Aspects (N) then |
| |
| -- The protected type is the full view of a private type. Analyze the |
| -- aspects with the entity of the private type to ensure that after |
| -- both views are exchanged, the aspect are actually associated with |
| -- the full view. |
| |
| if T /= Def_Id and then Is_Private_Type (Def_Id) then |
| Analyze_Aspect_Specifications (N, T); |
| else |
| Analyze_Aspect_Specifications (N, Def_Id); |
| end if; |
| end if; |
| |
| Analyze (Protected_Definition (N)); |
| |
| -- In the case where the protected type is declared at a nested level |
| -- and the No_Local_Protected_Objects restriction applies, issue a |
| -- warning that objects of the type will violate the restriction. |
| |
| if Restriction_Check_Required (No_Local_Protected_Objects) |
| and then not Is_Library_Level_Entity (T) |
| and then Comes_From_Source (T) |
| then |
| Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects); |
| |
| if Error_Msg_Sloc = No_Location then |
| Error_Msg_N |
| ("objects of this type will violate " & |
| "`No_Local_Protected_Objects`??", N); |
| else |
| Error_Msg_N |
| ("objects of this type will violate " & |
| "`No_Local_Protected_Objects`#??", N); |
| end if; |
| end if; |
| |
| -- Protected types with entries are controlled (because of the |
| -- Protection component if nothing else), same for any protected type |
| -- with interrupt handlers. Note that we need to analyze the protected |
| -- definition to set Has_Entries and such. |
| |
| if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False |
| or else Number_Entries (T) > 1) |
| and then not Restricted_Profile |
| and then |
| (Has_Entries (T) |
| or else Has_Interrupt_Handler (T) |
| or else Has_Attach_Handler (T)) |
| then |
| 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. |
| |
| E := First_Entity (Current_Scope); |
| while Present (E) loop |
| if Ekind (E) = E_Void then |
| Set_Ekind (E, E_Component); |
| Init_Component_Location (E); |
| end if; |
| |
| Next_Entity (E); |
| end loop; |
| |
| End_Scope; |
| |
| -- When a Lock_Free aspect forces the lock-free implementation, check N |
| -- meets all the lock-free restrictions. Otherwise, an error message is |
| -- issued by Allows_Lock_Free_Implementation. |
| |
| if Uses_Lock_Free (Defining_Identifier (N)) then |
| |
| -- Complain when there is an explicit aspect/pragma Priority (or |
| -- Interrupt_Priority) while the lock-free implementation is forced |
| -- by an aspect/pragma. |
| |
| declare |
| Id : constant Entity_Id := Defining_Identifier (Original_Node (N)); |
| -- The warning must be issued on the original identifier in order |
| -- to deal properly with the case of a single protected object. |
| |
| Prio_Item : constant Node_Id := |
| Get_Rep_Item (Def_Id, Name_Priority, False); |
| |
| begin |
| if Present (Prio_Item) then |
| |
| -- Aspect case |
| |
| if Nkind (Prio_Item) = N_Aspect_Specification |
| or else From_Aspect_Specification (Prio_Item) |
| then |
| Error_Msg_Name_1 := Chars (Identifier (Prio_Item)); |
| Error_Msg_NE |
| ("aspect% for & has no effect when Lock_Free given??", |
| Prio_Item, Id); |
| |
| -- Pragma case |
| |
| else |
| Error_Msg_Name_1 := Pragma_Name (Prio_Item); |
| Error_Msg_NE |
| ("pragma% for & has no effect when Lock_Free given??", |
| Prio_Item, Id); |
| end if; |
| end if; |
| end; |
| |
| if not Allows_Lock_Free_Implementation (N, Lock_Free_Given => True) |
| then |
| return; |
| end if; |
| end if; |
| |
| -- If the Attach_Handler aspect is specified or the Interrupt_Handler |
| -- aspect is True, then the initial ceiling priority must be in the |
| -- range of System.Interrupt_Priority. It is therefore recommanded |
| -- to use the Interrupt_Priority aspect instead of the Priority aspect. |
| |
| if Has_Interrupt_Handler (T) or else Has_Attach_Handler (T) then |
| declare |
| Prio_Item : constant Node_Id := |
| Get_Rep_Item (Def_Id, Name_Priority, False); |
| |
| begin |
| if Present (Prio_Item) then |
| |
| -- Aspect case |
| |
| if (Nkind (Prio_Item) = N_Aspect_Specification |
| or else From_Aspect_Specification (Prio_Item)) |
| and then Chars (Identifier (Prio_Item)) = Name_Priority |
| then |
| Error_Msg_N |
| ("aspect Interrupt_Priority is preferred in presence of " |
| & "handlers??", Prio_Item); |
| |
| -- Pragma case |
| |
| elsif Nkind (Prio_Item) = N_Pragma |
| and then Pragma_Name (Prio_Item) = Name_Priority |
| then |
| Error_Msg_N |
| ("pragma Interrupt_Priority is preferred in presence of " |
| & "handlers??", Prio_Item); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Case of a completion of a private declaration |
| |
| if T /= Def_Id and then Is_Private_Type (Def_Id) then |
| |
| -- Deal with preelaborable initialization. Note that this processing |
| -- is done by Process_Full_View, but as can be seen below, in this |
| -- case the call to Process_Full_View is skipped if any serious |
| -- errors have occurred, and we don't want to lose this check. |
| |
| if Known_To_Have_Preelab_Init (Def_Id) then |
| Set_Must_Have_Preelab_Init (T); |
| end if; |
| |
| -- Propagate Default_Initial_Condition-related attributes from the |
| -- private type to the protected type. |
| |
| Propagate_DIC_Attributes (T, From_Typ => Def_Id); |
| |
| -- Propagate invariant-related attributes from the private type to |
| -- the protected type. |
| |
| Propagate_Invariant_Attributes (T, From_Typ => Def_Id); |
| |
| -- Create corresponding record now, because some private dependents |
| -- may be subtypes of the partial view. |
| |
| -- Skip if errors are present, to prevent cascaded messages |
| |
| if Serious_Errors_Detected = 0 |
| |
| -- Also skip if expander is not active |
| |
| and then Expander_Active |
| then |
| Expand_N_Protected_Type_Declaration (N); |
| Process_Full_View (N, T, Def_Id); |
| end if; |
| end if; |
| |
| -- In GNATprove mode, force the loading of a Interrupt_Priority, which |
| -- is required for the ceiling priority protocol checks triggered by |
| -- calls originating from protected subprograms and entries. |
| |
| if GNATprove_Mode then |
| SPARK_Implicit_Load (RE_Interrupt_Priority); |
| end if; |
| end Analyze_Protected_Type_Declaration; |
| |
| --------------------- |
| -- Analyze_Requeue -- |
| --------------------- |
| |
| procedure Analyze_Requeue (N : Node_Id) is |
| Count : Natural := 0; |
| Entry_Name : Node_Id := Name (N); |
| Entry_Id : Entity_Id; |
| I : Interp_Index; |
| Is_Disp_Req : Boolean; |
| It : Interp; |
| Enclosing : Entity_Id; |
| Target_Obj : Node_Id := Empty; |
| Req_Scope : Entity_Id; |
| Outer_Ent : Entity_Id; |
| Synch_Type : Entity_Id := Empty; |
| |
| begin |
| -- Preserve relevant elaboration-related attributes of the context which |
| -- are no longer available or very expensive to recompute once analysis, |
| -- resolution, and expansion are over. |
| |
| Mark_Elaboration_Attributes |
| (N_Id => N, |
| Checks => True, |
| Modes => True, |
| Warnings => True); |
| |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("requeue statement is not allowed", N); |
| Check_Restriction (No_Requeue_Statements, N); |
| Check_Unreachable_Code (N); |
| |
| Enclosing := Empty; |
| for J in reverse 0 .. Scope_Stack.Last loop |
| Enclosing := Scope_Stack.Table (J).Entity; |
| exit when Is_Entry (Enclosing); |
| |
| if not Ekind_In (Enclosing, E_Block, E_Loop) then |
| Error_Msg_N ("requeue must appear within accept or entry body", N); |
| return; |
| end if; |
| end loop; |
| |
| Analyze (Entry_Name); |
| |
| if Etype (Entry_Name) = Any_Type then |
| return; |
| end if; |
| |
| if Nkind (Entry_Name) = N_Selected_Component then |
| Target_Obj := Prefix (Entry_Name); |
| 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 Present (Target_Obj) then |
| |
| -- Locate containing concurrent unit and determine enclosing entry |
| -- body or outermost enclosing accept statement within the unit. |
| |
| Outer_Ent := Empty; |
| for S in reverse 0 .. Scope_Stack.Last loop |
| Req_Scope := Scope_Stack.Table (S).Entity; |
| |
| exit when Ekind (Req_Scope) in Task_Kind |
| or else Ekind (Req_Scope) in Protected_Kind; |
| |
| if Is_Entry (Req_Scope) then |
| Outer_Ent := Req_Scope; |
| end if; |
| end loop; |
| |
| 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). |
| |
| if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent) |
| and then |
| (not Is_Entity_Name (Target_Obj) |
| or else not Is_Formal (Entity (Target_Obj)) |
| or else Enclosing /= Scope (Entity (Target_Obj))) |
| then |
| Error_Msg_N |
| ("target object has invalid level for requeue", Target_Obj); |
| end if; |
| end if; |
| |
| -- Overloaded case, find right interpretation |
| |
| if Is_Overloaded (Entry_Name) then |
| Entry_Id := Empty; |
| |
| -- Loop over candidate interpretations and filter out any that are |
| -- not parameterless, are not type conformant, are not entries, or |
| -- do not come from source. |
| |
| Get_First_Interp (Entry_Name, I, It); |
| while Present (It.Nam) loop |
| |
| -- Note: we test type conformance here, not subtype conformance. |
| -- Subtype conformance will be tested later on, but it is better |
| -- for error output in some cases not to do that here. |
| |
| if (No (First_Formal (It.Nam)) |
| or else (Type_Conformant (Enclosing, It.Nam))) |
| and then Ekind (It.Nam) = E_Entry |
| then |
| -- Ada 2005 (AI-345): Since protected and task types have |
| -- primitive entry wrappers, we only consider source entries. |
| |
| if Comes_From_Source (It.Nam) then |
| Count := Count + 1; |
| Entry_Id := It.Nam; |
| else |
| Remove_Interp (I); |
| end if; |
| end if; |
| |
| Get_Next_Interp (I, It); |
| end loop; |
| |
| if Count = 0 then |
| Error_Msg_N ("no entry matches context", N); |
| return; |
| |
| elsif Count > 1 then |
| Error_Msg_N ("ambiguous entry name in requeue", N); |
| return; |
| |
| else |
| Set_Is_Overloaded (Entry_Name, False); |
| Set_Entity (Entry_Name, Entry_Id); |
| end if; |
| |
| -- Non-overloaded cases |
| |
| -- 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 |
| |
| -- Requeue to an entry out of the body |
| |
| if Nkind (Prefix (Entry_Name)) = N_Selected_Component then |
| Entry_Id := Entity (Selector_Name (Prefix (Entry_Name))); |
| |
| -- Requeue from within the body itself |
| |
| elsif Nkind (Prefix (Entry_Name)) = N_Identifier then |
| Entry_Id := Entity (Prefix (Entry_Name)); |
| |
| else |
| Error_Msg_N ("invalid entry_name specified", N); |
| return; |
| 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. |
| |
| elsif Nkind (Entry_Name) = N_Function_Call then |
| Error_Msg_N |
| ("arguments not allowed in requeue statement", |
| First (Parameter_Associations (Entry_Name))); |
| return; |
| |
| -- Normal case of no entry family, no argument |
| |
| else |
| Entry_Id := Entity (Entry_Name); |
| end if; |
| |
| -- Ada 2012 (AI05-0030): Potential dispatching requeue statement. The |
| -- target type must be a concurrent interface class-wide type and the |
| -- target must be a procedure, flagged by pragma Implemented. The |
| -- target may be an access to class-wide type, in which case it must |
| -- be dereferenced. |
| |
| if Present (Target_Obj) then |
| Synch_Type := Etype (Target_Obj); |
| |
| if Is_Access_Type (Synch_Type) then |
| Synch_Type := Designated_Type (Synch_Type); |
| end if; |
| end if; |
| |
| Is_Disp_Req := |
| Ada_Version >= Ada_2012 |
| and then Present (Target_Obj) |
| and then Is_Class_Wide_Type (Synch_Type) |
| and then Is_Concurrent_Interface (Synch_Type) |
| and then Ekind (Entry_Id) = E_Procedure |
| and then Has_Rep_Pragma (Entry_Id, Name_Implemented); |
| |
| -- Resolve entry, and check that it is subtype conformant with the |
| -- enclosing construct if this construct has formals (RM 9.5.4(5)). |
| -- Ada 2005 (AI05-0030): Do not emit an error for this specific case. |
| |
| if not Is_Entry (Entry_Id) |
| and then not Is_Disp_Req |
| then |
| Error_Msg_N ("expect entry name in requeue statement", Name (N)); |
| |
| elsif Ekind (Entry_Id) = E_Entry_Family |
| and then Nkind (Entry_Name) /= N_Indexed_Component |
| then |
| Error_Msg_N ("missing index for entry family component", Name (N)); |
| |
| else |
| Resolve_Entry (Name (N)); |
| Generate_Reference (Entry_Id, Entry_Name); |
| |
| if Present (First_Formal (Entry_Id)) then |
| |
| -- Ada 2012 (AI05-0030): Perform type conformance after skipping |
| -- the first parameter of Entry_Id since it is the interface |
| -- controlling formal. |
| |
| if Ada_Version >= Ada_2012 and then Is_Disp_Req then |
| declare |
| Enclosing_Formal : Entity_Id; |
| Target_Formal : Entity_Id; |
| |
| begin |
| Enclosing_Formal := First_Formal (Enclosing); |
| Target_Formal := Next_Formal (First_Formal (Entry_Id)); |
| while Present (Enclosing_Formal) |
| and then Present (Target_Formal) |
| loop |
| if not Conforming_Types |
| (T1 => Etype (Enclosing_Formal), |
| T2 => Etype (Target_Formal), |
| Ctype => Subtype_Conformant) |
| then |
| Error_Msg_Node_2 := Target_Formal; |
| Error_Msg_NE |
| ("formal & is not subtype conformant with &" & |
| "in dispatching requeue", N, Enclosing_Formal); |
| end if; |
| |
| Next_Formal (Enclosing_Formal); |
| Next_Formal (Target_Formal); |
| end loop; |
| end; |
| else |
| Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); |
| end if; |
| |
| -- Processing for parameters accessed by the requeue |
| |
| declare |
| Ent : Entity_Id; |
| |
| begin |
| 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. |
| |
| if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then |
| Set_Never_Set_In_Source (Ent, False); |
| Set_Is_True_Constant (Ent, False); |
| 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. |
| |
| Set_Referenced (Ent); |
| Next_Formal (Ent); |
| end loop; |
| end; |
| end if; |
| end if; |
| |
| -- AI05-0225: the target protected object of a requeue must be a |
| -- variable. This is a binding interpretation that applies to all |
| -- versions of the language. Note that the subprogram does not have |
| -- to be a protected operation: it can be an primitive implemented |
| -- by entry with a formal that is a protected interface. |
| |
| if Present (Target_Obj) |
| and then not Is_Variable (Target_Obj) |
| then |
| Error_Msg_N |
| ("target protected object of requeue must be a variable", N); |
| end if; |
| |
| -- A requeue statement is treated as a call for purposes of ABE checks |
| -- and diagnostics. Annotate the tree by creating a call marker in case |
| -- the requeue statement is transformed by expansion. |
| |
| Build_Call_Marker (N); |
| end Analyze_Requeue; |
| |
| ------------------------------ |
| -- Analyze_Selective_Accept -- |
| ------------------------------ |
| |
| procedure Analyze_Selective_Accept (N : Node_Id) is |
| Alts : constant List_Id := Select_Alternatives (N); |
| Alt : Node_Id; |
| |
| Accept_Present : Boolean := False; |
| Terminate_Present : Boolean := False; |
| Delay_Present : Boolean := False; |
| Relative_Present : Boolean := False; |
| Alt_Count : Uint := Uint_0; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("select statement is not allowed", N); |
| Check_Restriction (No_Select_Statements, N); |
| |
| -- Loop to analyze alternatives |
| |
| Alt := First (Alts); |
| while Present (Alt) loop |
| Alt_Count := Alt_Count + 1; |
| Analyze (Alt); |
| |
| if Nkind (Alt) = N_Delay_Alternative then |
| if Delay_Present then |
| |
| if Relative_Present /= |
| (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement) |
| then |
| Error_Msg_N |
| ("delay_until and delay_relative alternatives ", Alt); |
| Error_Msg_N |
| ("\cannot appear in the same selective_wait", Alt); |
| end if; |
| |
| else |
| Delay_Present := True; |
| Relative_Present := |
| Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement; |
| end if; |
| |
| elsif Nkind (Alt) = N_Terminate_Alternative then |
| if Terminate_Present then |
| Error_Msg_N ("only one terminate alternative allowed", N); |
| else |
| Terminate_Present := True; |
| Check_Restriction (No_Terminate_Alternatives, N); |
| end if; |
| |
| elsif Nkind (Alt) = N_Accept_Alternative then |
| Accept_Present := True; |
| |
| -- Check for duplicate accept |
| |
| declare |
| Alt1 : Node_Id; |
| Stm : constant Node_Id := Accept_Statement (Alt); |
| EDN : constant Node_Id := Entry_Direct_Name (Stm); |
| Ent : Entity_Id; |
| |
| begin |
| if Nkind (EDN) = N_Identifier |
| and then No (Condition (Alt)) |
| and then Present (Entity (EDN)) -- defend against junk |
| and then Ekind (Entity (EDN)) = E_Entry |
| then |
| Ent := Entity (EDN); |
| |
| Alt1 := First (Alts); |
| while Alt1 /= Alt loop |
| if Nkind (Alt1) = N_Accept_Alternative |
| and then No (Condition (Alt1)) |
| then |
| declare |
| Stm1 : constant Node_Id := Accept_Statement (Alt1); |
| EDN1 : constant Node_Id := Entry_Direct_Name (Stm1); |
| |
| begin |
| if Nkind (EDN1) = N_Identifier then |
| if Entity (EDN1) = Ent then |
| Error_Msg_Sloc := Sloc (Stm1); |
| Error_Msg_N |
| ("accept duplicates one on line#??", Stm); |
| exit; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| Next (Alt1); |
| end loop; |
| end if; |
| end; |
| end if; |
| |
| Next (Alt); |
| end loop; |
| |
| Check_Restriction (Max_Select_Alternatives, N, Alt_Count); |
| Check_Potentially_Blocking_Operation (N); |
| |
| if Terminate_Present and Delay_Present then |
| Error_Msg_N ("at most one of terminate or delay alternative", N); |
| |
| elsif not Accept_Present then |
| Error_Msg_N |
| ("select must contain at least one accept alternative", N); |
| end if; |
| |
| if Present (Else_Statements (N)) then |
| if Terminate_Present or Delay_Present then |
| Error_Msg_N ("else part not allowed with other alternatives", N); |
| end if; |
| |
| Analyze_Statements (Else_Statements (N)); |
| end if; |
| end Analyze_Selective_Accept; |
| |
| ------------------------------------------ |
| -- Analyze_Single_Protected_Declaration -- |
| ------------------------------------------ |
| |
| procedure Analyze_Single_Protected_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Obj_Id : constant Node_Id := Defining_Identifier (N); |
| Obj_Decl : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| Generate_Definition (Obj_Id); |
| Tasking_Used := True; |
| |
| -- A single protected declaration is transformed into a pair of an |
| -- anonymous protected type and an object of that type. Generate: |
| |
| -- protected type Typ is ...; |
| |
| Typ := |
| Make_Defining_Identifier (Sloc (Obj_Id), |
| Chars => New_External_Name (Chars (Obj_Id), 'T')); |
| |
| Rewrite (N, |
| Make_Protected_Type_Declaration (Loc, |
| Defining_Identifier => Typ, |
| Protected_Definition => Relocate_Node (Protected_Definition (N)), |
| Interface_List => Interface_List (N))); |
| |
| -- Use the original defining identifier of the single protected |
| -- declaration in the generated object declaration to allow for debug |
| -- information to be attached to it when compiling with -gnatD. The |
| -- parent of the entity is the new object declaration. The single |
| -- protected declaration is not used in semantics or code generation, |
| -- but is scanned when generating debug information, and therefore needs |
| -- the updated Sloc information from the entity (see Sprint). Generate: |
| |
| -- Obj : Typ; |
| |
| Obj_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Obj_Id, |
| Object_Definition => New_Occurrence_Of (Typ, Loc)); |
| |
| Insert_After (N, Obj_Decl); |
| Mark_Rewrite_Insertion (Obj_Decl); |
| |
| -- Relocate aspect Part_Of from the the original single protected |
| -- declaration to the anonymous object declaration. This emulates the |
| -- placement of an equivalent source pragma. |
| |
| Move_Or_Merge_Aspects (N, To => Obj_Decl); |
| |
| -- Relocate pragma Part_Of from the visible declarations of the original |
| -- single protected declaration to the anonymous object declaration. The |
| -- new placement better reflects the role of the pragma. |
| |
| Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); |
| |
| -- Enter the names of the anonymous protected type and the object before |
| -- analysis takes places, because the name of the object may be used in |
| -- its own body. |
| |
| Enter_Name (Typ); |
| Set_Ekind (Typ, E_Protected_Type); |
| Set_Etype (Typ, Typ); |
| Set_Anonymous_Object (Typ, Obj_Id); |
| |
| Enter_Name (Obj_Id); |
| Set_Ekind (Obj_Id, E_Variable); |
| Set_Etype (Obj_Id, Typ); |
| Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Obj_Id); |
| |
| -- 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_Declaration (N); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Obj_Id); |
| end if; |
| end Analyze_Single_Protected_Declaration; |
| |
| ------------------------------------- |
| -- Analyze_Single_Task_Declaration -- |
| ------------------------------------- |
| |
| procedure Analyze_Single_Task_Declaration (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Obj_Id : constant Node_Id := Defining_Identifier (N); |
| Obj_Decl : Node_Id; |
| Typ : Entity_Id; |
| |
| begin |
| Generate_Definition (Obj_Id); |
| Tasking_Used := True; |
| |
| -- A single task declaration is transformed into a pair of an anonymous |
| -- task type and an object of that type. Generate: |
| |
| -- task type Typ is ...; |
| |
| Typ := |
| Make_Defining_Identifier (Sloc (Obj_Id), |
| Chars => New_External_Name (Chars (Obj_Id), Suffix => "TK")); |
| |
| Rewrite (N, |
| Make_Task_Type_Declaration (Loc, |
| Defining_Identifier => Typ, |
| Task_Definition => Relocate_Node (Task_Definition (N)), |
| Interface_List => Interface_List (N))); |
| |
| -- Use the original defining identifier of the single task declaration |
| -- in the generated object declaration to allow for debug information |
| -- to be attached to it when compiling with -gnatD. The parent of the |
| -- entity is the new object declaration. The single task declaration |
| -- is not used in semantics or code generation, but is scanned when |
| -- generating debug information, and therefore needs the updated Sloc |
| -- information from the entity (see Sprint). Generate: |
| |
| -- Obj : Typ; |
| |
| Obj_Decl := |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Obj_Id, |
| Object_Definition => New_Occurrence_Of (Typ, Loc)); |
| |
| Insert_After (N, Obj_Decl); |
| Mark_Rewrite_Insertion (Obj_Decl); |
| |
| -- Relocate aspects Depends, Global and Part_Of from the original single |
| -- task declaration to the anonymous object declaration. This emulates |
| -- the placement of an equivalent source pragma. |
| |
| Move_Or_Merge_Aspects (N, To => Obj_Decl); |
| |
| -- Relocate pragmas Depends, Global and Part_Of from the visible |
| -- declarations of the original single protected declaration to the |
| -- anonymous object declaration. The new placement better reflects the |
| -- role of the pragmas. |
| |
| Relocate_Pragmas_To_Anonymous_Object (N, Obj_Decl); |
| |
| -- Enter the names of the anonymous task type and the object before |
| -- analysis takes places, because the name of the object may be used |
| -- in its own body. |
| |
| Enter_Name (Typ); |
| Set_Ekind (Typ, E_Task_Type); |
| Set_Etype (Typ, Typ); |
| Set_Anonymous_Object (Typ, Obj_Id); |
| |
| Enter_Name (Obj_Id); |
| Set_Ekind (Obj_Id, E_Variable); |
| Set_Etype (Obj_Id, Typ); |
| Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Obj_Id); |
| |
| -- Preserve relevant elaboration-related attributes of the context which |
| -- are no longer available or very expensive to recompute once analysis, |
| -- resolution, and expansion are over. |
| |
| Mark_Elaboration_Attributes |
| (N_Id => Obj_Id, |
| Checks => True, |
| Warnings => True); |
| |
| -- 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_Declaration (N); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Obj_Id); |
| end if; |
| end Analyze_Single_Task_Declaration; |
| |
| ----------------------- |
| -- Analyze_Task_Body -- |
| ----------------------- |
| |
| procedure Analyze_Task_Body (N : Node_Id) is |
| Body_Id : constant Entity_Id := Defining_Identifier (N); |
| Decls : constant List_Id := Declarations (N); |
| HSS : constant Node_Id := Handled_Statement_Sequence (N); |
| 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. |
| |
| 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). |
| |
| begin |
| -- A task body freezes the contract of the nearest enclosing package |
| -- body and all other contracts encountered in the same declarative part |
| -- up to and excluding the task body. This ensures that annotations |
| -- referenced by the contract of an entry or subprogram body declared |
| -- within the current protected body are available. |
| |
| Freeze_Previous_Contracts (N); |
| |
| Tasking_Used := True; |
| Set_Scope (Body_Id, Current_Scope); |
| Set_Ekind (Body_Id, E_Task_Body); |
| Set_Etype (Body_Id, Standard_Void_Type); |
| Spec_Id := Find_Concurrent_Spec (Body_Id); |
| |
| -- The spec is either a task type declaration, or a single task |
| -- declaration for which we have created an anonymous type. |
| |
| if Present (Spec_Id) and then Ekind (Spec_Id) = E_Task_Type then |
| null; |
| |
| elsif Present (Spec_Id) |
| and then Ekind (Etype (Spec_Id)) = E_Task_Type |
| and then not Comes_From_Source (Etype (Spec_Id)) |
| then |
| null; |
| |
| else |
| Error_Msg_N ("missing specification for task body", Body_Id); |
| return; |
| end if; |
| |
| if Has_Completion (Spec_Id) |
| and then Present (Corresponding_Body (Parent (Spec_Id))) |
| then |
| if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then |
| Error_Msg_NE ("duplicate body for task type&", N, Spec_Id); |
| else |
| Error_Msg_NE ("duplicate body for task&", N, Spec_Id); |
| end if; |
| end if; |
| |
| Ref_Id := Spec_Id; |
| Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False); |
| Style.Check_Identifier (Body_Id, Spec_Id); |
| |
| -- Deal with case of body of single task (anonymous type was created) |
| |
| if Ekind (Spec_Id) = E_Variable then |
| Spec_Id := Etype (Spec_Id); |
| end if; |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with an explicit pragma). |
| |
| Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (Body_Id); |
| |
| if Has_Aspects (N) then |
| Analyze_Aspect_Specifications (N, Body_Id); |
| end if; |
| |
| Push_Scope (Spec_Id); |
| Set_Corresponding_Spec (N, Spec_Id); |
| Set_Corresponding_Body (Parent (Spec_Id), Body_Id); |
| Set_Has_Completion (Spec_Id); |
| Install_Declarations (Spec_Id); |
| Last_E := Last_Entity (Spec_Id); |
| |
| Analyze_Declarations (Decls); |
| Inspect_Deferred_Constant_Completion (Decls); |
| |
| -- 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 |
| Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E)); |
| else |
| Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id)); |
| end if; |
| end if; |
| |
| -- Mark all handlers as not suitable for local raise optimization, |
| -- since this optimization causes difficulties in a task context. |
| |
| if Present (Exception_Handlers (HSS)) then |
| declare |
| Handlr : Node_Id; |
| begin |
| Handlr := First (Exception_Handlers (HSS)); |
| while Present (Handlr) loop |
| Set_Local_Raise_Not_OK (Handlr); |
| Next (Handlr); |
| end loop; |
| end; |
| end if; |
| |
| -- Now go ahead and complete analysis of the task body |
| |
| Analyze (HSS); |
| Check_Completion (Body_Id); |
| Check_References (Body_Id); |
| Check_References (Spec_Id); |
| |
| -- Check for entries with no corresponding accept |
| |
| declare |
| Ent : Entity_Id; |
| |
| begin |
| Ent := First_Entity (Spec_Id); |
| while Present (Ent) loop |
| if Is_Entry (Ent) |
| and then not Entry_Accepted (Ent) |
| and then Comes_From_Source (Ent) |
| then |
| Error_Msg_NE ("no accept for entry &??", N, Ent); |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| end; |
| |
| Process_End_Label (HSS, 't', Ref_Id); |
| Update_Use_Clause_Chain; |
| End_Scope; |
| end Analyze_Task_Body; |
| |
| ----------------------------- |
| -- Analyze_Task_Definition -- |
| ----------------------------- |
| |
| procedure Analyze_Task_Definition (N : Node_Id) is |
| L : Entity_Id; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("task definition is not allowed", N); |
| |
| if Present (Visible_Declarations (N)) then |
| Analyze_Declarations (Visible_Declarations (N)); |
| end if; |
| |
| if Present (Private_Declarations (N)) then |
| L := Last_Entity (Current_Scope); |
| Analyze_Declarations (Private_Declarations (N)); |
| |
| if Present (L) then |
| Set_First_Private_Entity |
| (Current_Scope, Next_Entity (L)); |
| else |
| Set_First_Private_Entity |
| (Current_Scope, First_Entity (Current_Scope)); |
| end if; |
| end if; |
| |
| Check_Max_Entries (N, Max_Task_Entries); |
| Process_End_Label (N, 'e', Current_Scope); |
| end Analyze_Task_Definition; |
| |
| ----------------------------------- |
| -- Analyze_Task_Type_Declaration -- |
| ----------------------------------- |
| |
| procedure Analyze_Task_Type_Declaration (N : Node_Id) is |
| Def_Id : constant Entity_Id := Defining_Identifier (N); |
| T : Entity_Id; |
| |
| begin |
| -- Attempt to use tasking in no run time mode is not allowe. Issue hard |
| -- error message to disable expansion which leads to crashes. |
| |
| if Opt.No_Run_Time_Mode then |
| Error_Msg_N ("tasking not allowed in No_Run_Time mode", N); |
| |
| -- Otherwise soft check for no tasking restriction |
| |
| else |
| Check_Restriction (No_Tasking, N); |
| end if; |
| |
| -- Proceed ahead with analysis of task type declaration |
| |
| Tasking_Used := True; |
| |
| -- The sequential partition elaboration policy is supported only in the |
| -- restricted profile. |
| |
| if Partition_Elaboration_Policy = 'S' |
| and then not Restricted_Profile |
| then |
| Error_Msg_N |
| ("sequential elaboration supported only in restricted profile", N); |
| end if; |
| |
| T := Find_Type_Name (N); |
| Generate_Definition (T); |
| |
| -- In the case of an incomplete type, use the full view, unless it's not |
| -- present (as can occur for an incomplete view from a limited with). |
| -- Initialize the Corresponding_Record_Type (which overlays the Private |
| -- Dependents field of the incomplete view). |
| |
| if Ekind (T) = E_Incomplete_Type then |
| if Present (Full_View (T)) then |
| T := Full_View (T); |
| Set_Completion_Referenced (T); |
| |
| else |
| Set_Ekind (T, E_Task_Type); |
| Set_Corresponding_Record_Type (T, Empty); |
| end if; |
| end if; |
| |
| Set_Ekind (T, E_Task_Type); |
| Set_Is_First_Subtype (T, True); |
| Set_Has_Task (T, True); |
| Init_Size_Align (T); |
| Set_Etype (T, T); |
| Set_Has_Delayed_Freeze (T, True); |
| Set_Stored_Constraint (T, No_Elist); |
| |
| -- Set the SPARK_Mode from the current context (may be overwritten later |
| -- with an explicit pragma). |
| |
| Set_SPARK_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Aux_Pragma (T, SPARK_Mode_Pragma); |
| Set_SPARK_Pragma_Inherited (T); |
| Set_SPARK_Aux_Pragma_Inherited (T); |
| |
| -- Preserve relevant elaboration-related attributes of the context which |
| -- are no longer available or very expensive to recompute once analysis, |
| -- resolution, and expansion are over. |
| |
| Mark_Elaboration_Attributes |
| (N_Id => T, |
| Checks => True, |
| Warnings => True); |
| |
| Push_Scope (T); |
| |
| if Ada_Version >= Ada_2005 then |
| Check_Interfaces (N, T); |
| end if; |
| |
| if Present (Discriminant_Specifications (N)) then |
| if Ada_Version = Ada_83 and then Comes_From_Source (N) then |
| Error_Msg_N ("(Ada 83) task discriminant not allowed!", N); |
| end if; |
| |
| if Has_Discriminants (T) then |
| |
| -- Install discriminants. Also, verify conformance of |
| -- discriminants of previous and current view. ??? |
| |
| Install_Declarations (T); |
| else |
| Process_Discriminants (N); |
| end if; |
| end if; |
| |
| Set_Is_Constrained (T, not Has_Discriminants (T)); |
| |
| if Has_Aspects (N) then |
| |
| -- The task type is the full view of a private type. Analyze the |
| -- aspects with the entity of the private type to ensure that after |
| -- both views are exchanged, the aspect are actually associated with |
| -- the full view. |
| |
| if T /= Def_Id and then Is_Private_Type (Def_Id) then |
| Analyze_Aspect_Specifications (N, T); |
| else |
| Analyze_Aspect_Specifications (N, Def_Id); |
| end if; |
| end if; |
| |
| if Present (Task_Definition (N)) then |
| Analyze_Task_Definition (Task_Definition (N)); |
| end if; |
| |
| -- In the case where the task type is declared at a nested level and the |
| -- No_Task_Hierarchy restriction applies, issue a warning that objects |
| -- of the type will violate the restriction. |
| |
| if Restriction_Check_Required (No_Task_Hierarchy) |
| and then not Is_Library_Level_Entity (T) |
| and then Comes_From_Source (T) |
| and then not CodePeer_Mode |
| then |
| Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy); |
| |
| if Error_Msg_Sloc = No_Location then |
| Error_Msg_N |
| ("objects of this type will violate `No_Task_Hierarchy`??", N); |
| else |
| Error_Msg_N |
| ("objects of this type will violate `No_Task_Hierarchy`#??", N); |
| end if; |
| end if; |
| |
| End_Scope; |
| |
| -- Case of a completion of a private declaration |
| |
| if T /= Def_Id and then Is_Private_Type (Def_Id) then |
| |
| -- Deal with preelaborable initialization. Note that this processing |
| -- is done by Process_Full_View, but as can be seen below, in this |
| -- case the call to Process_Full_View is skipped if any serious |
| -- errors have occurred, and we don't want to lose this check. |
| |
| if Known_To_Have_Preelab_Init (Def_Id) then |
| Set_Must_Have_Preelab_Init (T); |
| end if; |
| |
| -- Propagate Default_Initial_Condition-related attributes from the |
| -- private type to the task type. |
| |
| Propagate_DIC_Attributes (T, From_Typ => Def_Id); |
| |
| -- Propagate invariant-related attributes from the private type to |
| -- task type. |
| |
| Propagate_Invariant_Attributes (T, From_Typ => Def_Id); |
| |
| -- Create corresponding record now, because some private dependents |
| -- may be subtypes of the partial view. |
| |
| -- Skip if errors are present, to prevent cascaded messages |
| |
| if Serious_Errors_Detected = 0 |
| |
| -- Also skip if expander is not active |
| |
| and then Expander_Active |
| then |
| Expand_N_Task_Type_Declaration (N); |
| Process_Full_View (N, T, Def_Id); |
| end if; |
| end if; |
| |
| -- In GNATprove mode, force the loading of a Interrupt_Priority, which |
| -- is required for the ceiling priority protocol checks triggered by |
| -- calls originating from tasks. |
| |
| if GNATprove_Mode then |
| SPARK_Implicit_Load (RE_Interrupt_Priority); |
| end if; |
| end Analyze_Task_Type_Declaration; |
| |
| ----------------------------------- |
| -- Analyze_Terminate_Alternative -- |
| ----------------------------------- |
| |
| procedure Analyze_Terminate_Alternative (N : Node_Id) is |
| begin |
| Tasking_Used := True; |
| |
| if Present (Pragmas_Before (N)) then |
| Analyze_List (Pragmas_Before (N)); |
| end if; |
| |
| if Present (Condition (N)) then |
| Analyze_And_Resolve (Condition (N), Any_Boolean); |
| end if; |
| end Analyze_Terminate_Alternative; |
| |
| ------------------------------ |
| -- Analyze_Timed_Entry_Call -- |
| ------------------------------ |
| |
| procedure Analyze_Timed_Entry_Call (N : Node_Id) is |
| Trigger : constant Node_Id := |
| Entry_Call_Statement (Entry_Call_Alternative (N)); |
| Is_Disp_Select : Boolean := False; |
| |
| begin |
| Tasking_Used := True; |
| Check_SPARK_05_Restriction ("select statement is not allowed", N); |
| Check_Restriction (No_Select_Statements, N); |
| |
| -- Ada 2005 (AI-345): The trigger may be a dispatching call |
| |
| if Ada_Version >= Ada_2005 then |
| Analyze (Trigger); |
| Check_Triggering_Statement (Trigger, N, Is_Disp_Select); |
| end if; |
| |
| -- Postpone the analysis of the statements till expansion. Analyze only |
| -- if the expander is disabled in order to catch any semantic errors. |
| |
| if Is_Disp_Select then |
| if not Expander_Active then |
| Analyze (Entry_Call_Alternative (N)); |
| Analyze (Delay_Alternative (N)); |
| end if; |
| |
| -- Regular select analysis |
| |
| else |
| Analyze (Entry_Call_Alternative (N)); |
| Analyze (Delay_Alternative (N)); |
| end if; |
| end Analyze_Timed_Entry_Call; |
| |
| ------------------------------------ |
| -- Analyze_Triggering_Alternative -- |
| ------------------------------------ |
| |
| procedure Analyze_Triggering_Alternative (N : Node_Id) is |
| Trigger : constant Node_Id := Triggering_Statement (N); |
| |
| begin |
| Tasking_Used := True; |
| |
| if Present (Pragmas_Before (N)) then |
| Analyze_List (Pragmas_Before (N)); |
| end if; |
| |
| Analyze (Trigger); |
| |
| if Comes_From_Source (Trigger) |
| and then Nkind (Trigger) not in N_Delay_Statement |
| and then Nkind (Trigger) /= N_Entry_Call_Statement |
| then |
| if Ada_Version < Ada_2005 then |
| Error_Msg_N |
| ("triggering statement must be delay or entry call", Trigger); |
| |
| -- Ada 2005 (AI-345): If a procedure_call_statement is used for a |
| -- procedure_or_entry_call, the procedure_name or procedure_prefix |
| -- of the procedure_call_statement shall denote an entry renamed by a |
| -- procedure, or (a view of) a primitive subprogram of a limited |
| -- interface whose first parameter is a controlling parameter. |
| |
| elsif Nkind (Trigger) = N_Procedure_Call_Statement |
| and then not Is_Renamed_Entry (Entity (Name (Trigger))) |
| and then not Is_Controlling_Limited_Procedure |
| (Entity (Name (Trigger))) |
| then |
| Error_Msg_N |
| ("triggering statement must be procedure or entry call " & |
| "or delay statement", Trigger); |
| end if; |
| end if; |
| |
| if Is_Non_Empty_List (Statements (N)) then |
| Analyze_Statements (Statements (N)); |
| end if; |
| end Analyze_Triggering_Alternative; |
| |
| ----------------------- |
| -- Check_Max_Entries -- |
| ----------------------- |
| |
| procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is |
| Ecount : Uint; |
| |
| procedure Count (L : List_Id); |
| -- Count entries in given declaration list |
| |
| ----------- |
| -- Count -- |
| ----------- |
| |
| procedure Count (L : List_Id) is |
| D : Node_Id; |
| |
| begin |
| if No (L) then |
| return; |
| end if; |
| |
| D := First (L); |
| while Present (D) loop |
| if Nkind (D) = N_Entry_Declaration then |
| declare |
| DSD : constant Node_Id := |
| Discrete_Subtype_Definition (D); |
| |
| begin |
| -- If not an entry family, then just one entry |
| |
| if No (DSD) then |
| Ecount := Ecount + 1; |
| |
| -- If entry family with static bounds, count entries |
| |
| elsif Is_OK_Static_Subtype (Etype (DSD)) then |
| declare |
| Lo : constant Uint := |
| Expr_Value |
| (Type_Low_Bound (Etype (DSD))); |
| Hi : constant Uint := |
| Expr_Value |
| (Type_High_Bound (Etype (DSD))); |
| |
| begin |
| if Hi >= Lo then |
| Ecount := Ecount + Hi - Lo + 1; |
| end if; |
| end; |
| |
| -- Entry family with non-static bounds |
| |
| else |
| -- Record an unknown count restriction, and if the |
| -- restriction is active, post a message or warning. |
| |
| Check_Restriction (R, D); |
| end if; |
| end; |
| end if; |
| |
| Next (D); |
| end loop; |
| end Count; |
| |
| -- Start of processing for Check_Max_Entries |
| |
| begin |
| Ecount := Uint_0; |
| Count (Visible_Declarations (D)); |
| Count (Private_Declarations (D)); |
| |
| if Ecount > 0 then |
| Check_Restriction (R, D, Ecount); |
| end if; |
| end Check_Max_Entries; |
| |
| ---------------------- |
| -- Check_Interfaces -- |
| ---------------------- |
| |
| procedure Check_Interfaces (N : Node_Id; T : Entity_Id) is |
| Iface : Node_Id; |
| Iface_Typ : Entity_Id; |
| |
| begin |
| pragma Assert |
| (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration)); |
| |
| if Present (Interface_List (N)) then |
| Set_Is_Tagged_Type (T); |
| |
| -- The primitive operations of a tagged synchronized type are placed |
| -- on the Corresponding_Record for proper dispatching, but are |
| -- attached to the synchronized type itself when expansion is |
| -- disabled, for ASIS use. |
| |
| Set_Direct_Primitive_Operations (T, New_Elmt_List); |
| |
| Iface := First (Interface_List (N)); |
| while Present (Iface) loop |
| Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); |
| |
| if not Is_Interface (Iface_Typ) then |
| Error_Msg_NE |
| ("(Ada 2005) & must be an interface", 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. |
| |
| Freeze_Before (N, Etype (Iface)); |
| |
| if Nkind (N) = N_Protected_Type_Declaration then |
| |
| -- Ada 2005 (AI-345): Protected types can only implement |
| -- limited, synchronized, or protected interfaces (note that |
| -- the predicate Is_Limited_Interface includes synchronized |
| -- and protected interfaces). |
| |
| if Is_Task_Interface (Iface_Typ) then |
| Error_Msg_N ("(Ada 2005) protected type cannot implement " |
| & "a task interface", Iface); |
| |
| elsif not Is_Limited_Interface (Iface_Typ) then |
| Error_Msg_N ("(Ada 2005) protected type cannot implement " |
| & "a non-limited interface", Iface); |
| end if; |
| |
| else pragma Assert (Nkind (N) = N_Task_Type_Declaration); |
| |
| -- Ada 2005 (AI-345): Task types can only implement limited, |
| -- synchronized, or task interfaces (note that the predicate |
| -- Is_Limited_Interface includes synchronized and task |
| -- interfaces). |
| |
| if Is_Protected_Interface (Iface_Typ) then |
| Error_Msg_N ("(Ada 2005) task type cannot implement a " & |
| "protected interface", Iface); |
| |
| elsif not Is_Limited_Interface (Iface_Typ) then |
| Error_Msg_N ("(Ada 2005) task type cannot implement a " & |
| "non-limited interface", Iface); |
| end if; |
| end if; |
| end if; |
| |
| Next (Iface); |
| end loop; |
| end if; |
| |
| if not Has_Private_Declaration (T) then |
| return; |
| end if; |
| |
| -- Additional checks on full-types associated with private type |
| -- declarations. Search for the private type declaration. |
| |
| declare |
| Full_T_Ifaces : Elist_Id := No_Elist; |
| Iface : Node_Id; |
| Priv_T : Entity_Id; |
| Priv_T_Ifaces : Elist_Id := No_Elist; |
| |
| begin |
| Priv_T := First_Entity (Scope (T)); |
| loop |
| pragma Assert (Present (Priv_T)); |
| |
| if Is_Type (Priv_T) and then Present (Full_View (Priv_T)) then |
| exit when Full_View (Priv_T) = T; |
| end if; |
| |
| Next_Entity (Priv_T); |
| end loop; |
| |
| -- In case of synchronized types covering interfaces the private type |
| -- declaration must be limited. |
| |
| if Present (Interface_List (N)) |
| and then not Is_Limited_Type (Priv_T) |
| then |
| Error_Msg_Sloc := Sloc (Priv_T); |
| Error_Msg_N ("(Ada 2005) limited type declaration expected for " & |
| "private type#", T); |
| end if; |
| |
| -- RM 7.3 (7.1/2): If the full view has a partial view that is |
| -- tagged then check RM 7.3 subsidiary rules. |
| |
| if Is_Tagged_Type (Priv_T) |
| and then not Error_Posted (N) |
| then |
| -- RM 7.3 (7.2/2): The partial view shall be a synchronized tagged |
| -- type if and only if the full type is a synchronized tagged type |
| |
| if Is_Synchronized_Tagged_Type (Priv_T) |
| and then not Is_Synchronized_Tagged_Type (T) |
| then |
| Error_Msg_N |
| ("(Ada 2005) full view must be a synchronized tagged " & |
| "type (RM 7.3 (7.2/2))", Priv_T); |
| |
| elsif Is_Synchronized_Tagged_Type (T) |
| and then not Is_Synchronized_Tagged_Type (Priv_T) |
| then |
| Error_Msg_N |
| ("(Ada 2005) partial view must be a synchronized tagged " & |
| "type (RM 7.3 (7.2/2))", T); |
| end if; |
| |
| -- RM 7.3 (7.3/2): The partial view shall be a descendant of an |
| -- interface type if and only if the full type is descendant of |
| -- the interface type. |
| |
| if Present (Interface_List (N)) |
| or else (Is_Tagged_Type (Priv_T) |
| and then Has_Interfaces |
| (Priv_T, Use_Full_View => False)) |
| then |
| if Is_Tagged_Type (Priv_T) then |
| Collect_Interfaces |
| (Priv_T, Priv_T_Ifaces, Use_Full_View => False); |
| end if; |
| |
| if Is_Tagged_Type (T) then |
| Collect_Interfaces (T, Full_T_Ifaces); |
| end if; |
| |
| Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces); |
| |
| if Present (Iface) then |
| Error_Msg_NE |
| ("interface in partial view& not implemented by full " |
| & "type (RM-2005 7.3 (7.3/2))", T, Iface); |
| end if; |
| |
| Iface := Find_Hidden_Interface (Full_T_Ifaces, Priv_T_Ifaces); |
| |
| if Present (Iface) then |
| Error_Msg_NE |
| ("interface & not implemented by partial " & |
| "view (RM-2005 7.3 (7.3/2))", T, Iface); |
| end if; |
| end if; |
| end if; |
| end; |
| end Check_Interfaces; |
| |
| -------------------------------- |
| -- Check_Triggering_Statement -- |
| -------------------------------- |
| |
| procedure Check_Triggering_Statement |
| (Trigger : Node_Id; |
| Error_Node : Node_Id; |
| Is_Dispatching : out Boolean) |
| is |
| Param : Node_Id; |
| |
| begin |
| Is_Dispatching := False; |
| |
| -- It is not possible to have a dispatching trigger if we are not in |
| -- Ada 2005 mode. |
| |
| if Ada_Version >= Ada_2005 |
| and then Nkind (Trigger) = N_Procedure_Call_Statement |
| and then Present (Parameter_Associations (Trigger)) |
| then |
| Param := First (Parameter_Associations (Trigger)); |
| |
| if Is_Controlling_Actual (Param) |
| and then Is_Interface (Etype (Param)) |
| then |
| if Is_Limited_Record (Etype (Param)) then |
| Is_Dispatching := True; |
| else |
| Error_Msg_N |
| ("dispatching operation of limited or synchronized " & |
| "interface required (RM 9.7.2(3))!", Error_Node); |
| end if; |
| |
| elsif Nkind (Trigger) = N_Explicit_Dereference then |
| Error_Msg_N |
| ("entry call or dispatching primitive of interface required ", |
| Trigger); |
| end if; |
| end if; |
| end Check_Triggering_Statement; |
| |
| -------------------------- |
| -- Find_Concurrent_Spec -- |
| -------------------------- |
| |
| function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is |
| Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id); |
| |
| begin |
| -- The type may have been given by an incomplete type declaration. |
| -- Find full view now. |
| |
| if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then |
| Spec_Id := Full_View (Spec_Id); |
| end if; |
| |
| return Spec_Id; |
| end Find_Concurrent_Spec; |
| |
| -------------------------- |
| -- Install_Declarations -- |
| -------------------------- |
| |
| procedure Install_Declarations (Spec : Entity_Id) is |
| E : Entity_Id; |
| Prev : Entity_Id; |
| begin |
| E := First_Entity (Spec); |
| while Present (E) loop |
| Prev := Current_Entity (E); |
| Set_Current_Entity (E); |
| Set_Is_Immediately_Visible (E); |
| Set_Homonym (E, Prev); |
| Next_Entity (E); |
| end loop; |
| end Install_Declarations; |
| |
| end Sem_Ch9; |