blob: d7bff861585fdb91ce7bd142305c6dac6c2f937d [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ C H 9 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2003, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch9;
with Elists; use Elists;
with Itypes; use Itypes;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
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_Eval; use Sem_Eval;
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 --
-----------------------
procedure Check_Max_Entries (Def : Node_Id; R : Restriction_Parameter_Id);
-- Given either a protected definition or a task definition in Def, 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.
function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
procedure Install_Declarations (Spec : Entity_Id);
-- Utility to make visible in corresponding body the entities defined
-- in task, protected type declaration, or entry declaration.
-----------------------------
-- Analyze_Abort_Statement --
-----------------------------
procedure Analyze_Abort_Statement (N : Node_Id) is
T_Name : Node_Id;
begin
Tasking_Used := True;
T_Name := First (Names (N));
while Present (T_Name) loop
Analyze (T_Name);
if not Is_Task_Type (Etype (T_Name)) then
Error_Msg_N ("expect task name for ABORT", T_Name);
return;
else
Resolve (T_Name);
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);
Ityp : Entity_Id;
Entry_Nam : Entity_Id;
E : Entity_Id;
Kind : Entity_Kind;
Task_Nam : Entity_Id;
-----------------------
-- Actual_Index_Type --
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id;
-- If the bounds of an entry family depend on task discriminants,
-- create a new index type where a discriminant is replaced by the
-- local variable that renames it in the task body.
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
Typ : constant Entity_Id := Entry_Index_Type (E);
Lo : constant Node_Id := Type_Low_Bound (Typ);
Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If bound is discriminant reference, replace with corresponding
-- local variable of the same name.
-----------------------------
-- Actual_Discriminant_Ref --
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
if not Is_Entity_Name (Bound)
or else Ekind (Entity (Bound)) /= E_Discriminant
then
return Bound;
else
Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
Analyze (Ref);
Resolve (Ref, Typ);
return Ref;
end if;
end Actual_Discriminant_Ref;
-- Start of processing for Actual_Index_Type
begin
if not Has_Discriminants (Task_Nam)
or else (not Is_Entity_Name (Lo)
and then not Is_Entity_Name (Hi))
then
return Entry_Index_Type (E);
else
New_T := Create_Itype (Ekind (Typ), N);
Set_Etype (New_T, Base_Type (Typ));
Set_Size_Info (New_T, Typ);
Set_RM_Size (New_T, RM_Size (Typ));
Set_Scalar_Range (New_T,
Make_Range (Sloc (N),
Low_Bound => Actual_Discriminant_Ref (Lo),
High_Bound => Actual_Discriminant_Ref (Hi)));
return New_T;
end if;
end Actual_Index_Type;
-- Start of processing for Analyze_Accept_Statement
begin
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_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.
if Present (Index) then
Ityp := New_Internal_Entity
(E_Entry_Family, Current_Scope, Sloc (N), 'E');
else
Ityp := New_Internal_Entity
(E_Entry, Current_Scope, Sloc (N), 'E');
end if;
Set_Etype (Ityp, Standard_Void_Type);
Set_Accept_Address (Ityp, New_Elmt_List);
if Present (Formals) then
New_Scope (Ityp);
Process_Formals (Formals, N);
Create_Extra_Formals (Ityp);
End_Scope;
end if;
-- We set the default expressions processed flag because we don't
-- need default expression functions. This is really more like a
-- body entity than a spec entity anyway.
Set_Default_Expressions_Processed (Ityp);
E := First_Entity (Etype (Task_Nam));
while Present (E) loop
if Chars (E) = Chars (Nam)
and then (Ekind (E) = Ekind (Ityp))
and then Type_Conformant (Ityp, 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 (Ityp, Convention (Entry_Nam));
Check_Fully_Conformant (Ityp, 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_Task_Body | N_Compilation_Unit =>
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, Actual_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.
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).
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);
end if;
Next_Entity (E);
end loop;
-- Analyze statements if present
if Present (Stats) then
New_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
begin
Tasking_Used := True;
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
-- Analyze the statements. We analyze statements in the abortable part
-- first, because this is the section that is executed first, and that
-- way our remembering of saved values and checks is accurate.
Analyze_Statements (Statements (Abortable_Part (N)));
Analyze (Triggering_Alternative (N));
end Analyze_Asynchronous_Select;
------------------------------------
-- Analyze_Conditional_Entry_Call --
------------------------------------
procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
begin
Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
Analyze (Entry_Call_Alternative (N));
Analyze_Statements (Else_Statements (N));
end Analyze_Conditional_Entry_Call;
--------------------------------
-- Analyze_Delay_Alternative --
--------------------------------
procedure Analyze_Delay_Alternative (N : Node_Id) is
Expr : Node_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 (Parent (N)) = N_Selective_Accept
or else Nkind (Parent (N)) = 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
Pre_Analyze_And_Resolve (Expr, Standard_Duration);
else
Pre_Analyze_And_Resolve (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
Check_Restriction (No_Relative_Delay, N);
Tasking_Used := True;
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E, Standard_Duration);
Check_Restriction (No_Fixed_Point, E);
end Analyze_Delay_Relative;
-------------------------
-- Analyze_Delay_Until --
-------------------------
procedure Analyze_Delay_Until (N : Node_Id) is
E : constant Node_Id := Expression (N);
begin
Tasking_Used := True;
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze (E);
if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
not Is_RTE (Base_Type (Etype (E)), 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;
Entry_Name : Entity_Id;
E : Entity_Id;
begin
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_Scope (Id, Current_Scope);
Set_Etype (Id, Standard_Void_Type);
Set_Accept_Address (Id, New_Elmt_List);
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 (Entry_Name), 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);
Set_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);
New_Scope (Entry_Name);
Exp_Ch9.Expand_Entry_Body_Declarations (N);
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 to corresponding_spec, and there is no
-- easy link back in the tree between the entry body and the entity for
-- the entry itself.
Set_Protected_Body_Subprogram (Id,
Protected_Body_Subprogram (Entry_Name));
if Present (Decls) then
Analyze_Declarations (Decls);
end if;
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.
-- 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.
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 forget
-- about worrying 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);
<<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);
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);
end if;
if Present (Formals) then
Set_Scope (Id, Current_Scope);
New_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;
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
-- illegalitles, such as procedure calls, are diagnosed after
-- resolution.
Error_Msg_N ("entry call alternative requires an entry call", Call);
return;
end if;
Analyze (Call);
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
Formals : constant List_Id := Parameter_Specifications (N);
Id : constant Entity_Id := Defining_Identifier (N);
D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
begin
Generate_Definition (Id);
Tasking_Used := True;
if No (D_Sdef) then
Set_Ekind (Id, E_Entry);
else
Enter_Name (Id);
Set_Ekind (Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Id);
end if;
Set_Etype (Id, Standard_Void_Type);
Set_Convention (Id, Convention_Entry);
Set_Accept_Address (Id, New_Elmt_List);
if Present (Formals) then
Set_Scope (Id, Current_Scope);
New_Scope (Id);
Process_Formals (Formals, N);
Create_Extra_Formals (Id);
End_Scope;
end if;
if Ekind (Id) = E_Entry then
New_Overloaded_Entity (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 must be available in the entry barrier,
-- which is evaluated outside of the entry body. The index is eventually
-- renamed as a run-time object, so is visibility is strictly a front-end
-- concern. In order to make it available to the barrier, we create
-- an additional scope, as for a loop, whose only declaration is the
-- index name. This loop is not attached to the tree and does not appear
-- as an entity local to the protected type, so its existence need only
-- be knwown to routines that process entry families.
procedure Analyze_Entry_Index_Specification (N : Node_Id) is
Iden : constant Node_Id := Defining_Identifier (N);
Def : constant Node_Id := Discrete_Subtype_Definition (N);
Loop_Id : constant Entity_Id :=
Make_Defining_Identifier (Sloc (N),
Chars => New_Internal_Name ('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);
New_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).
begin
Tasking_Used := True;
Set_Ekind (Body_Id, E_Protected_Body);
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;
New_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);
Exp_Ch9.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);
End_Scope;
end Analyze_Protected_Body;
----------------------------------
-- Analyze_Protected_Definition --
----------------------------------
procedure Analyze_Protected_Definition (N : Node_Id) is
E : Entity_Id;
L : Entity_Id;
begin
Tasking_Used := True;
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 (E) = E_Function
or else Ekind (E) = E_Procedure
then
Set_Convention (E, Convention_Protected);
elsif Is_Task_Type (Etype (E))
or else Has_Task (Etype (E))
then
Set_Has_Task (Current_Scope);
end if;
Next_Entity (E);
end loop;
Check_Max_Entries (N, Max_Protected_Entries);
Process_End_Label (N, 'e', Current_Scope);
end Analyze_Protected_Definition;
----------------------------
-- Analyze_Protected_Type --
----------------------------
procedure Analyze_Protected_Type (N : Node_Id) is
E : Entity_Id;
T : Entity_Id;
Def_Id : constant Entity_Id := Defining_Identifier (N);
begin
if No_Run_Time_Mode then
Error_Msg_CRT ("protected type", N);
return;
end if;
Tasking_Used := True;
Check_Restriction (No_Protected_Types, N);
T := Find_Type_Name (N);
if Ekind (T) = E_Incomplete_Type then
T := Full_View (T);
Set_Completion_Referenced (T);
end if;
Set_Ekind (T, E_Protected_Type);
Init_Size_Align (T);
Set_Etype (T, T);
Set_Is_First_Subtype (T, True);
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
New_Scope (T);
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;
Analyze (Protected_Definition (N));
-- 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 Restrictions (No_Entry_Queue) = False
or else Number_Entries (T) > 1)
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;
if T /= Def_Id
and then Is_Private_Type (Def_Id)
and then Has_Discriminants (Def_Id)
and then Expander_Active
then
Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end Analyze_Protected_Type;
---------------------
-- Analyze_Requeue --
---------------------
procedure Analyze_Requeue (N : Node_Id) is
Entry_Name : Node_Id := Name (N);
Entry_Id : Entity_Id;
Found : Boolean;
I : Interp_Index;
It : Interp;
Enclosing : Entity_Id;
Target_Obj : Node_Id := Empty;
Req_Scope : Entity_Id;
Outer_Ent : Entity_Id;
begin
Check_Restriction (No_Requeue, N);
Check_Unreachable_Code (N);
Tasking_Used := True;
Enclosing := Empty;
for J in reverse 0 .. Scope_Stack.Last loop
Enclosing := Scope_Stack.Table (J).Entity;
exit when Is_Entry (Enclosing);
if Ekind (Enclosing) /= E_Block
and then Ekind (Enclosing) /= 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 Ekind (Entity (Target_Obj)) not in Formal_Kind
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
Get_First_Interp (Entry_Name, I, It);
Found := False;
Entry_Id := Empty;
while Present (It.Nam) loop
if No (First_Formal (It.Nam))
or else Subtype_Conformant (Enclosing, It.Nam)
then
if not Found then
Found := True;
Entry_Id := It.Nam;
else
Error_Msg_N ("ambiguous entry name in requeue", N);
return;
end if;
end if;
Get_Next_Interp (I, It);
end loop;
if not Found then
Error_Msg_N ("no entry matches context", N);
return;
else
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;
-- Resolve entry, and check that it is subtype conformant with the
-- enclosing construct if this construct has formals (RM 9.5.4(5)).
if not Is_Entry (Entry_Id) 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
Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
-- Processing for parameters accessed by the requeue
declare
Ent : Entity_Id := First_Formal (Enclosing);
begin
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 (Ent) = E_Out_Parameter
or else
Ekind (Ent) = 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;
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
Check_Restriction (No_Select_Statements, N);
Check_Restriction (Max_Select_Alternatives, N);
Tasking_Used := True;
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, Alt_Count, N);
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 --
------------------------------
procedure Analyze_Single_Protected (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Node_Id := Defining_Identifier (N);
T : Entity_Id;
T_Decl : Node_Id;
O_Decl : Node_Id;
O_Name : constant Entity_Id := New_Copy (Id);
begin
Generate_Definition (Id);
Tasking_Used := True;
-- The node is rewritten as a protected type declaration,
-- in exact analogy with what is done with single tasks.
T :=
Make_Defining_Identifier (Sloc (Id),
New_External_Name (Chars (Id), 'T'));
T_Decl :=
Make_Protected_Type_Declaration (Loc,
Defining_Identifier => T,
Protected_Definition => Relocate_Node (Protected_Definition (N)));
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
-- Enter names of type and object before analysis, because the name
-- of the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Protected_Type);
Set_Etype (T, T);
Enter_Name (O_Name);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
-- Instead of calling Analyze on the new node, call directly
-- the proper analysis procedure. Otherwise the node would be
-- expanded twice, with disastrous result.
Analyze_Protected_Type (N);
end Analyze_Single_Protected;
-------------------------
-- Analyze_Single_Task --
-------------------------
procedure Analyze_Single_Task (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Node_Id := Defining_Identifier (N);
T : Entity_Id;
T_Decl : Node_Id;
O_Decl : Node_Id;
O_Name : constant Entity_Id := New_Copy (Id);
begin
Generate_Definition (Id);
Tasking_Used := True;
-- The node is rewritten as a task type declaration, followed
-- by an object declaration of that anonymous task type.
T :=
Make_Defining_Identifier (Sloc (Id),
New_External_Name (Chars (Id), Suffix => "TK"));
T_Decl :=
Make_Task_Type_Declaration (Loc,
Defining_Identifier => T,
Task_Definition => Relocate_Node (Task_Definition (N)));
O_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => O_Name,
Object_Definition => Make_Identifier (Loc, Chars (T)));
Rewrite (N, T_Decl);
Insert_After (N, O_Decl);
Mark_Rewrite_Insertion (O_Decl);
-- Enter names of type and object before analysis, because the name
-- of the object may be used in its own body.
Enter_Name (T);
Set_Ekind (T, E_Task_Type);
Set_Etype (T, T);
Enter_Name (O_Name);
Set_Ekind (O_Name, E_Variable);
Set_Etype (O_Name, T);
-- Instead of calling Analyze on the new node, call directly
-- the proper analysis procedure. Otherwise the node would be
-- expanded twice, with disastrous result.
Analyze_Task_Type (N);
end Analyze_Single_Task;
-----------------------
-- Analyze_Task_Body --
-----------------------
procedure Analyze_Task_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 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
Tasking_Used := True;
Set_Ekind (Body_Id, E_Task_Body);
Set_Scope (Body_Id, Current_Scope);
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;
New_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 (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;
Analyze (Handled_Statement_Sequence (N));
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 (Handled_Statement_Sequence (N), 't', Ref_Id);
End_Scope;
end Analyze_Task_Body;
-----------------------------
-- Analyze_Task_Definition --
-----------------------------
procedure Analyze_Task_Definition (N : Node_Id) is
L : Entity_Id;
begin
Tasking_Used := True;
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 --
-----------------------
procedure Analyze_Task_Type (N : Node_Id) is
T : Entity_Id;
Def_Id : constant Entity_Id := Defining_Identifier (N);
begin
Tasking_Used := True;
Check_Restriction (No_Tasking, N);
T := Find_Type_Name (N);
Generate_Definition (T);
if Ekind (T) = E_Incomplete_Type then
T := Full_View (T);
Set_Completion_Referenced (T);
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);
New_Scope (T);
if Present (Discriminant_Specifications (N)) then
if 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;
if Present (Task_Definition (N)) then
Analyze_Task_Definition (Task_Definition (N));
end if;
if not Is_Library_Level_Entity (T) then
Check_Restriction (No_Task_Hierarchy, N);
end if;
End_Scope;
if T /= Def_Id
and then Is_Private_Type (Def_Id)
and then Has_Discriminants (Def_Id)
and then Expander_Active
then
Exp_Ch9.Expand_N_Task_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
end Analyze_Task_Type;
-----------------------------------
-- 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
begin
Check_Restriction (No_Select_Statements, N);
Tasking_Used := True;
Analyze (Entry_Call_Alternative (N));
Analyze (Delay_Alternative (N));
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) /= N_Delay_Until_Statement
and then Nkind (Trigger) /= N_Delay_Relative_Statement
and then Nkind (Trigger) /= N_Entry_Call_Statement
then
Error_Msg_N
("triggering statement must be delay or entry call", Trigger);
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 (Def : Node_Id; R : Restriction_Parameter_Id) 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;
-- If entry family with non-static bounds, give error msg
elsif Restriction_Parameters (R) /= No_Uint then
Error_Msg_N
("static subtype required by Restriction pragma", DSD);
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 (Def));
Count (Private_Declarations (Def));
if Ecount > 0 then
Check_Restriction (R, Ecount, Def);
end if;
end Check_Max_Entries;
--------------------------
-- 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;