-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, 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- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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 Atree; use Atree;
+with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
-with Errout; use Errout;
with Exp_Smem; use Exp_Smem;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Exp_VFpt; use Exp_VFpt;
+with Namet; use Namet;
with Nmake; use Nmake;
+with Opt; use Opt;
+with Output; use Output;
with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
-with Tbuild; use Tbuild;
+with Sinput; use Sinput;
with Snames; use Snames;
+with Tbuild; use Tbuild;
package body Exp_Ch2 is
-- Local Subprograms --
-----------------------
+ procedure Expand_Current_Value (N : Node_Id);
+ -- N is a node for a variable whose Current_Value field is set. If N is
+ -- node is for a discrete type, replaces node with a copy of the referenced
+ -- value. This provides a limited form of value propagation for variables
+ -- which are initialized or assigned not been further modified at the time
+ -- of reference. The call has no effect if the Current_Value refers to a
+ -- conditional with condition other than equality.
+
procedure Expand_Discriminant (N : Node_Id);
-- An occurrence of a discriminant within a discriminated type is replaced
-- with the corresponding discriminal, that is to say the formal parameter
-- discriminants of records that appear in constraints of component of the
-- record, because Gigi uses the discriminant name to retrieve its value.
-- In the other hand, it has to be performed for default expressions of
- -- components because they are used in the record init procedure. See
- -- Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use.
- -- For discriminants of tasks and protected types, the transformation is
- -- more complex when it occurs within a default expression for an entry
- -- or protected operation. The corresponding default_expression_function
- -- has an additional parameter which is the target of an entry call, and
- -- the discriminant of the task must be replaced with a reference to the
+ -- components because they are used in the record init procedure. See Einfo
+ -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
+ -- discriminants of tasks and protected types, the transformation is more
+ -- complex when it occurs within a default expression for an entry or
+ -- protected operation. The corresponding default_expression_function has
+ -- an additional parameter which is the target of an entry call, and the
+ -- discriminant of the task must be replaced with a reference to the
-- discriminant of that formal parameter.
procedure Expand_Entity_Reference (N : Node_Id);
-- Common processing for expansion of identifiers and expanded names
+ -- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id);
- -- A reference to the identifier in the entry index specification
- -- of a protected entry body is modified to a reference to a constant
- -- definintion equal to the index of the entry family member being
- -- called. This constant is calculated as part of the elaboration
- -- of the expanded code for the body, and is calculated from the
- -- object-wide entry index returned by Next_Entry_Call.
+ -- A reference to the identifier in the entry index specification of an
+ -- entry body is modified to a reference to a constant definition equal to
+ -- the index of the entry family member being called. This constant is
+ -- calculated as part of the elaboration of the expanded code for the body,
+ -- and is calculated from the object-wide entry index returned by Next_
+ -- Entry_Call.
procedure Expand_Entry_Parameter (N : Node_Id);
- -- A reference to an entry parameter is modified to be a reference to
- -- the corresponding component of the entry parameter record that is
- -- passed by the runtime to the accept body procedure
+ -- A reference to an entry parameter is modified to be a reference to the
+ -- corresponding component of the entry parameter record that is passed by
+ -- the runtime to the accept body procedure.
procedure Expand_Formal (N : Node_Id);
- -- A reference to a formal parameter of a protected subprogram is
- -- expanded to the corresponding formal of the unprotected procedure
- -- used to represent the protected subprogram within the protected object.
+ -- A reference to a formal parameter of a protected subprogram is expanded
+ -- into the corresponding formal of the unprotected procedure used to
+ -- represent the operation within the protected object. In other cases
+ -- Expand_Formal is a no-op.
- procedure Expand_Protected_Private (N : Node_Id);
- -- A reference to a private object of a protected type is expanded
- -- to a component selected from the record used to implement
- -- the protected object. Such a record is passed to all operations
- -- on a protected object in a parameter named _object. Such an object
- -- is a constant within a function, and a variable otherwise.
+ procedure Expand_Protected_Component (N : Node_Id);
+ -- A reference to a private component of a protected type is expanded into
+ -- a reference to the corresponding prival in the current protected entry
+ -- or subprogram.
procedure Expand_Renaming (N : Node_Id);
-- For renamings, just replace the identifier by the corresponding
- -- name expression. Note that this has been evaluated (see routine
+ -- named expression. Note that this has been evaluated (see routine
-- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
-- the correct renaming semantics.
+ --------------------------
+ -- Expand_Current_Value --
+ --------------------------
+
+ procedure Expand_Current_Value (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ E : constant Entity_Id := Entity (N);
+ CV : constant Node_Id := Current_Value (E);
+ T : constant Entity_Id := Etype (N);
+ Val : Node_Id;
+ Op : Node_Kind;
+
+ -- Start of processing for Expand_Current_Value
+
+ begin
+ if True
+
+ -- No replacement if value raises constraint error
+
+ and then Nkind (CV) /= N_Raise_Constraint_Error
+
+ -- Do this only for discrete types
+
+ and then Is_Discrete_Type (T)
+
+ -- Do not replace biased types, since it is problematic to
+ -- consistently generate a sensible constant value in this case.
+
+ and then not Has_Biased_Representation (T)
+
+ -- Do not replace lvalues
+
+ and then not May_Be_Lvalue (N)
+
+ -- Check that entity is suitable for replacement
+
+ and then OK_To_Do_Constant_Replacement (E)
+
+ -- Do not replace occurrences in pragmas (where names typically
+ -- appear not as values, but as simply names. If there are cases
+ -- where values are required, it is only a very minor efficiency
+ -- issue that they do not get replaced when they could be).
+
+ and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
+
+ -- Do not replace the prefixes of attribute references, since this
+ -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
+ -- Name_Asm_Output, don't do replacement anywhere, since we can have
+ -- lvalue references in the arguments.
+
+ and then not (Nkind (Parent (N)) = N_Attribute_Reference
+ and then
+ (Nam_In (Attribute_Name (Parent (N)),
+ Name_Asm_Input,
+ Name_Asm_Output)
+ or else Prefix (Parent (N)) = N))
+
+ then
+ -- Case of Current_Value is a compile time known value
+
+ if Nkind (CV) in N_Subexpr then
+ Val := CV;
+
+ -- Case of Current_Value is an if expression reference
+
+ else
+ Get_Current_Value_Condition (N, Op, Val);
+
+ if Op /= N_Op_Eq then
+ return;
+ end if;
+ end if;
+
+ -- If constant value is an occurrence of an enumeration literal,
+ -- then we just make another occurrence of the same literal.
+
+ if Is_Entity_Name (Val)
+ and then Ekind (Entity (Val)) = E_Enumeration_Literal
+ then
+ Rewrite (N,
+ Unchecked_Convert_To (T,
+ New_Occurrence_Of (Entity (Val), Loc)));
+
+ -- If constant is of a character type, just make an appropriate
+ -- character literal, which will get the proper type.
+
+ elsif Is_Character_Type (T) then
+ Rewrite (N,
+ Make_Character_Literal (Loc,
+ Chars => Chars (Val),
+ Char_Literal_Value => Expr_Rep_Value (Val)));
+
+ -- If constant is of an integer type, just make an appropriate
+ -- integer literal, which will get the proper type.
+
+ elsif Is_Integer_Type (T) then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Rep_Value (Val)));
+
+ -- Otherwise do unchecked conversion of value to right type
+
+ else
+ Rewrite (N,
+ Unchecked_Convert_To (T,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Rep_Value (Val))));
+ end if;
+
+ Analyze_And_Resolve (N, T);
+ Set_Is_Static_Expression (N, False);
+ end if;
+ end Expand_Current_Value;
+
-------------------------
-- Expand_Discriminant --
-------------------------
if Ekind (Scop) = E_Record_Type
or Ekind (Scop) in Incomplete_Or_Private_Kind
then
-
-- Find the origin by walking up the tree till the component
-- declaration
Parent_P := Parent (Parent_P);
end loop;
- -- If the discriminant occurs within the default expression for
- -- a formal of an entry or protected operation, create a default
- -- function for it, and replace the discriminant with a reference
- -- to the discriminant of the formal of the default function.
- -- The discriminant entity is the one defined in the corresponding
- -- record.
+ -- If the discriminant occurs within the default expression for a
+ -- formal of an entry or protected operation, replace it with a
+ -- reference to the discriminant of the formal of the enclosing
+ -- operation.
if Present (Parent_P)
and then Present (Corresponding_Spec (Parent_P))
then
-
declare
Loc : constant Source_Ptr := Sloc (N);
- D_Fun : Entity_Id := Corresponding_Spec (Parent_P);
- Formal : Entity_Id := First_Formal (D_Fun);
+ D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
+ Formal : constant Entity_Id := First_Formal (D_Fun);
New_N : Node_Id;
Disc : Entity_Id;
begin
- -- Verify that we are within a default function: the type of
- -- its formal parameter is the same task or protected type.
+ -- Verify that we are within the body of an entry or protected
+ -- operation. Its first formal parameter is the synchronized
+ -- type itself.
if Present (Formal)
and then Etype (Formal) = Scope (Entity (N))
and then In_Entry
then
Set_Entity (N, CR_Discriminant (Entity (N)));
+
+ -- Finally, if the entity is the discriminant of the original
+ -- type declaration, and we are within the initialization
+ -- procedure for a task, the designated entity is the
+ -- discriminal of the task body. This can happen when the
+ -- argument of pragma Task_Name mentions a discriminant,
+ -- because the pragma is analyzed in the task declaration
+ -- but is expanded in the call to Create_Task in the init_proc.
+
+ elsif Within_Init_Proc then
+ Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));
else
Set_Entity (N, Discriminal (Entity (N)));
end if;
begin
-- Defend against errors
- if No (E) and then Total_Errors_Detected /= 0 then
+ if No (E) then
+ Check_Error_Detected;
return;
end if;
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
- elsif Ekind (E) = E_Component
- and then Is_Protected_Private (E)
- then
- Expand_Protected_Private (N);
+ elsif Is_Protected_Component (E) then
+ if No_Run_Time_Mode then
+ return;
+ else
+ Expand_Protected_Component (N);
+ end if;
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
then
Expand_Shared_Passive_Variable (N);
end if;
+
+ -- Test code for implementing the pragma Reviewable requirement of
+ -- classifying reads of scalars as referencing potentially uninitialized
+ -- objects or not.
+
+ if Debug_Flag_XX
+ and then Is_Scalar_Type (Etype (N))
+ and then (Is_Assignable (E) or else Is_Constant_Object (E))
+ and then Comes_From_Source (N)
+ and then Is_LHS (N) = No
+ and then not Is_Actual_Out_Parameter (N)
+ and then (Nkind (Parent (N)) /= N_Attribute_Reference
+ or else Attribute_Name (Parent (N)) /= Name_Valid)
+ then
+ Write_Location (Sloc (N));
+ Write_Str (": Read from scalar """);
+ Write_Name (Chars (N));
+ Write_Str ("""");
+
+ if Is_Known_Valid (E) then
+ Write_Str (", Is_Known_Valid");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- Set Atomic_Sync_Required if necessary for atomic variable. Note that
+ -- this processing does NOT apply to Volatile_Full_Access variables.
+
+ if Nkind_In (N, N_Identifier, N_Expanded_Name)
+ and then Ekind (E) = E_Variable
+ and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
+ then
+ declare
+ Set : Boolean;
+
+ begin
+ -- If variable is atomic, but type is not, setting depends on
+ -- disable/enable state for the variable.
+
+ if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
+ Set := not Atomic_Synchronization_Disabled (E);
+
+ -- If variable is not atomic, but its type is atomic, setting
+ -- depends on disable/enable state for the type.
+
+ elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
+ Set := not Atomic_Synchronization_Disabled (Etype (E));
+
+ -- Else both variable and type are atomic (see outer if), and we
+ -- disable if either variable or its type have sync disabled.
+
+ else
+ Set := (not Atomic_Synchronization_Disabled (E))
+ and then
+ (not Atomic_Synchronization_Disabled (Etype (E)));
+ end if;
+
+ -- Set flag if required
+
+ if Set then
+ Activate_Atomic_Synchronization (N);
+ end if;
+ end;
+ end if;
+
+ -- Interpret possible Current_Value for variable case
+
+ if Is_Assignable (E)
+ and then Present (Current_Value (E))
+ then
+ Expand_Current_Value (N);
+
+ -- We do want to warn for the case of a boolean variable (not a
+ -- boolean constant) whose value is known at compile time.
+
+ if Is_Boolean_Type (Etype (N)) then
+ Warn_On_Known_Condition (N);
+ end if;
+
+ -- Don't mess with Current_Value for compile time known values. Not
+ -- only is it unnecessary, but we could disturb an indication of a
+ -- static value, which could cause semantic trouble.
+
+ elsif Compile_Time_Known_Value (N) then
+ null;
+
+ -- Interpret possible Current_Value for constant case
+
+ elsif Is_Constant_Object (E)
+ and then Present (Current_Value (E))
+ then
+ Expand_Current_Value (N);
+ end if;
end Expand_Entity_Reference;
----------------------------------
----------------------------------
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
+ Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
begin
- Set_Entity (N, Entry_Index_Constant (Entity (N)));
+ Set_Entity (N, Index_Con);
+ Set_Etype (N, Etype (Index_Con));
end Expand_Entry_Index_Parameter;
----------------------------
Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
P_Comp_Ref : Entity_Id;
+ function In_Assignment_Context (N : Node_Id) return Boolean;
+ -- Check whether this is a context in which the entry formal may be
+ -- assigned to.
+
+ ---------------------------
+ -- In_Assignment_Context --
+ ---------------------------
+
+ function In_Assignment_Context (N : Node_Id) return Boolean is
+ begin
+ -- Case of use in a call
+
+ -- ??? passing a formal as actual for a mode IN formal is
+ -- considered as an assignment?
+
+ if Nkind_In (Parent (N), N_Procedure_Call_Statement,
+ N_Entry_Call_Statement)
+ or else (Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Name (Parent (N)))
+ then
+ return True;
+
+ -- Case of a parameter association: climb up to enclosing call
+
+ elsif Nkind (Parent (N)) = N_Parameter_Association then
+ return In_Assignment_Context (Parent (N));
+
+ -- Case of a selected component, indexed component or slice prefix:
+ -- climb up the tree, unless the prefix is of an access type (in
+ -- which case there is an implicit dereference, and the formal itself
+ -- is not being assigned to).
+
+ elsif Nkind_In (Parent (N), N_Selected_Component,
+ N_Indexed_Component,
+ N_Slice)
+ and then N = Prefix (Parent (N))
+ and then not Is_Access_Type (Etype (N))
+ and then In_Assignment_Context (Parent (N))
+ then
+ return True;
+
+ else
+ return False;
+ end if;
+ end In_Assignment_Context;
+
+ -- Start of processing for Expand_Entry_Parameter
+
begin
+ if Is_Task_Type (Scope (Ent_Spec))
+ and then Comes_From_Source (Ent_Formal)
+ then
+ -- Before replacing the formal with the local renaming that is used
+ -- in the accept block, note if this is an assignment context, and
+ -- note the modification to avoid spurious warnings, because the
+ -- original entity is not used further. If formal is unconstrained,
+ -- we also generate an extra parameter to hold the Constrained
+ -- attribute of the actual. No renaming is generated for this flag.
+
+ -- Calling Note_Possible_Modification in the expander is dubious,
+ -- because this generates a cross-reference entry, and should be
+ -- done during semantic processing so it is called in -gnatc mode???
+
+ if Ekind (Entity (N)) /= E_In_Parameter
+ and then In_Assignment_Context (N)
+ then
+ Note_Possible_Modification (N, Sure => True);
+ end if;
+ end if;
+
-- What we need is a reference to the corresponding component of the
- -- parameter record object. The Accept_Address field of the entry
- -- entity references the address variable that contains the address
- -- of the accept parameters record. We first have to do an unchecked
- -- conversion to turn this into a pointer to the parameter record and
- -- then we select the required parameter field.
+ -- parameter record object. The Accept_Address field of the entry entity
+ -- references the address variable that contains the address of the
+ -- accept parameters record. We first have to do an unchecked conversion
+ -- to turn this into a pointer to the parameter record and then we
+ -- select the required parameter field.
+
+ -- The same processing applies to protected entries, where the Accept_
+ -- Address is also the address of the Parameters record.
P_Comp_Ref :=
Make_Selected_Component (Loc,
Prefix =>
- Unchecked_Convert_To (Parm_Type,
- New_Reference_To (Addr_Ent, Loc)),
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (Parm_Type,
+ New_Occurrence_Of (Addr_Ent, Loc))),
Selector_Name =>
- New_Reference_To (Entry_Component (Ent_Formal), Loc));
+ New_Occurrence_Of (Entry_Component (Ent_Formal), Loc));
- -- For all types of parameters, the constructed parameter record
- -- object contains a pointer to the parameter. Thus we must
- -- dereference them to access them (this will often be redundant,
- -- since the needed deference is implicit, but no harm is done by
- -- making it explicit).
+ -- For all types of parameters, the constructed parameter record object
+ -- contains a pointer to the parameter. Thus we must dereference them to
+ -- access them (this will often be redundant, since the dereference is
+ -- implicit, but no harm is done by making it explicit).
Rewrite (N,
Make_Explicit_Dereference (Loc, P_Comp_Ref));
procedure Expand_Formal (N : Node_Id) is
E : constant Entity_Id := Entity (N);
- Subp : constant Entity_Id := Scope (E);
+ Scop : constant Entity_Id := Scope (E);
begin
- if Is_Protected_Type (Scope (Subp))
- and then Chars (Subp) /= Name_uInit_Proc
+ -- Check whether the subprogram of which this is a formal is
+ -- a protected operation. The initialization procedure for
+ -- the corresponding record type is not itself a protected operation.
+
+ if Is_Protected_Type (Scope (Scop))
+ and then not Is_Init_Proc (Scop)
and then Present (Protected_Formal (E))
then
Set_Entity (N, Protected_Formal (E));
---------------------------
procedure Expand_N_Real_Literal (N : Node_Id) is
+ pragma Unreferenced (N);
+
begin
- if Vax_Float (Etype (N)) then
- Expand_Vax_Real_Literal (N);
- end if;
- end Expand_N_Real_Literal;
+ -- Historically, this routine existed because there were expansion
+ -- requirements for Vax real literals, but now Vax real literals
+ -- are now handled by gigi, so this routine no longer does anything.
- ------------------------------
- -- Expand_Protected_Private --
- ------------------------------
+ null;
+ end Expand_N_Real_Literal;
- procedure Expand_Protected_Private (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- E : constant Entity_Id := Entity (N);
- Op : constant Node_Id := Protected_Operation (E);
- Scop : Entity_Id;
- Lo : Node_Id;
- Hi : Node_Id;
- D_Range : Node_Id;
+ --------------------------------
+ -- Expand_Protected_Component --
+ --------------------------------
- begin
- if Nkind (Op) /= N_Subprogram_Body
- or else Nkind (Specification (Op)) /= N_Function_Specification
- then
- Set_Ekind (Prival (E), E_Variable);
- else
- Set_Ekind (Prival (E), E_Constant);
- end if;
+ procedure Expand_Protected_Component (N : Node_Id) is
- -- If the private component appears in an assignment (either lhs or
- -- rhs) and is a one-dimensional array constrained by a discriminant,
- -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
- -- is directly visible. This solves delicate visibility problems.
+ function Inside_Eliminated_Body return Boolean;
+ -- Determine whether the current entity is inside a subprogram or an
+ -- entry which has been marked as eliminated.
- if Comes_From_Source (N)
- and then Is_Array_Type (Etype (E))
- and then Number_Dimensions (Etype (E)) = 1
- and then not Within_Init_Proc
- then
- Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
- Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
-
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then ((Is_Entity_Name (Lo)
- and then Ekind (Entity (Lo)) = E_In_Parameter)
- or else (Is_Entity_Name (Hi)
- and then
- Ekind (Entity (Hi)) = E_In_Parameter))
- then
- D_Range := New_Node (N_Range, Loc);
+ ----------------------------
+ -- Inside_Eliminated_Body --
+ ----------------------------
- if Is_Entity_Name (Lo)
- and then Ekind (Entity (Lo)) = E_In_Parameter
- then
- Set_Low_Bound (D_Range,
- Make_Identifier (Loc, Chars (Entity (Lo))));
- else
- Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
- end if;
+ function Inside_Eliminated_Body return Boolean is
+ S : Entity_Id := Current_Scope;
- if Is_Entity_Name (Hi)
- and then Ekind (Entity (Hi)) = E_In_Parameter
+ begin
+ while Present (S) loop
+ if (Ekind (S) = E_Entry
+ or else Ekind (S) = E_Entry_Family
+ or else Ekind (S) = E_Function
+ or else Ekind (S) = E_Procedure)
+ and then Is_Eliminated (S)
then
- Set_High_Bound (D_Range,
- Make_Identifier (Loc, Chars (Entity (Hi))));
- else
- Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
+ return True;
end if;
- Rewrite (N,
- Make_Slice (Loc,
- Prefix => New_Occurrence_Of (E, Loc),
- Discrete_Range => D_Range));
-
- Analyze_And_Resolve (N, Etype (E));
- return;
- end if;
- end if;
-
- -- The type of the reference is the type of the prival, which may
- -- differ from that of the original component if it is an itype.
-
- Set_Entity (N, Prival (E));
- Set_Etype (N, Etype (Prival (E)));
- Scop := Current_Scope;
+ S := Scope (S);
+ end loop;
- -- Find entity for protected operation, which must be on scope stack.
+ return False;
+ end Inside_Eliminated_Body;
- while not Is_Protected_Type (Scope (Scop)) loop
- Scop := Scope (Scop);
- end loop;
+ -- Start of processing for Expand_Protected_Component
- Append_Elmt (N, Privals_Chain (Scop));
- end Expand_Protected_Private;
+ begin
+ -- Eliminated bodies are not expanded and thus do not need privals
+
+ if not Inside_Eliminated_Body then
+ declare
+ Priv : constant Entity_Id := Prival (Entity (N));
+ begin
+ Set_Entity (N, Priv);
+ Set_Etype (N, Etype (Priv));
+ end;
+ end if;
+ end Expand_Protected_Component;
---------------------
-- Expand_Renaming --
begin
Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
- -- We mark the copy as unanalyzed, so that it is sure to be
- -- reanalyzed at the top level. This is needed in the packed
- -- case since we specifically avoided expanding packed array
- -- references when the renaming declaration was analyzed.
+ -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
+ -- at the top level. This is needed in the packed case since we
+ -- specifically avoided expanding packed array references when the
+ -- renaming declaration was analyzed.
Reset_Analyzed_Flags (N);
Analyze_And_Resolve (N, T);
------------------
-- This would be trivial, simply a test for an identifier that was a
- -- reference to a formal, if it were not for the fact that a previous
- -- call to Expand_Entry_Parameter will have modified the reference
- -- to the identifier to be of the form
+ -- reference to a formal, if it were not for the fact that a previous call
+ -- to Expand_Entry_Parameter will have modified the reference to the
+ -- identifier. A formal of a protected entity is rewritten as
-- typ!(recobj).rec.all'Constrained
-- where rec is a selector whose Entry_Formal link points to the formal
+ -- If the type of the entry parameter has a representation clause, then an
+ -- extra temp is involved (see below).
+
+ -- For a formal of a task entity, the formal is rewritten as a local
+ -- renaming.
+
+ -- In addition, a formal that is marked volatile because it is aliased
+ -- through an address clause is rewritten as dereference as well.
+
function Param_Entity (N : Node_Id) return Entity_Id is
+ Renamed_Obj : Node_Id;
+
begin
-- Simple reference case
- if Nkind (N) = N_Identifier then
+ if Nkind_In (N, N_Identifier, N_Expanded_Name) then
if Is_Formal (Entity (N)) then
return Entity (N);
+
+ -- Handle renamings of formal parameters and formals of tasks that
+ -- are rewritten as renamings.
+
+ elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
+ Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
+
+ if Is_Entity_Name (Renamed_Obj)
+ and then Is_Formal (Entity (Renamed_Obj))
+ then
+ return Entity (Renamed_Obj);
+
+ elsif
+ Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
+ then
+ return Entity (N);
+ end if;
end if;
else
if Nkind (N) = N_Explicit_Dereference then
declare
- P : constant Node_Id := Prefix (N);
- S : Node_Id;
+ P : Node_Id := Prefix (N);
+ S : Node_Id;
+ E : Entity_Id;
+ Decl : Node_Id;
begin
+ -- If the type of an entry parameter has a representation
+ -- clause, then the prefix is not a selected component, but
+ -- instead a reference to a temp pointing at the selected
+ -- component. In this case, set P to be the initial value of
+ -- that temp.
+
+ if Nkind (P) = N_Identifier then
+ E := Entity (P);
+
+ if Ekind (E) = E_Constant then
+ Decl := Parent (E);
+
+ if Nkind (Decl) = N_Object_Declaration then
+ P := Expression (Decl);
+ end if;
+ end if;
+ end if;
+
if Nkind (P) = N_Selected_Component then
S := Selector_Name (P);
if Present (Entry_Formal (Entity (S))) then
return Entry_Formal (Entity (S));
end if;
+
+ elsif Nkind (Original_Node (N)) = N_Identifier then
+ return Param_Entity (Original_Node (N));
end if;
end;
end if;
projects / thirdparty / gcc.git / blobdiff