-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, 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 Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
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 Sinput; use Sinput;
with Snames; use Snames;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id);
- -- A reference to the identifier in the entry index specification of
- -- protected 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.
+ -- 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
+ -- 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
-- into the corresponding formal of the unprotected procedure used to
-- represent the operation within the protected object. In other cases
- -- Expand_Formal is a noop.
+ -- Expand_Formal is a no-op.
- procedure Expand_Protected_Private (N : Node_Id);
- -- A reference to a private component 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. This object is a constant in the body of a
- -- function, and a variable within a procedure or entry body.
+ 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
and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
- -- Same for Asm_Input and Asm_Output attribute references
+ -- 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
(Attribute_Name (Parent (N)) = Name_Asm_Input
or else
- Attribute_Name (Parent (N)) = Name_Asm_Output))
+ Attribute_Name (Parent (N)) = Name_Asm_Output
+ or else
+ Prefix (Parent (N)) = N))
+
then
-- Case of Current_Value is a compile time known value
end if;
-- If constant value is an occurrence of an enumeration literal,
- -- then we just make another occurence of the same literal.
+ -- then we just make another occurrence of the same literal.
if Is_Entity_Name (Val)
and then Ekind (Entity (Val)) = E_Enumeration_Literal
Unchecked_Convert_To (T,
New_Occurrence_Of (Entity (Val), Loc)));
- -- Otherwise get the value, and convert to appropriate type
+ -- If constant is of an integer type, just make an appropriately
+ -- 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))));
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Rep_Value (Val))));
end if;
Analyze_And_Resolve (N, T);
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.
+ -- 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))
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;
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
- elsif Ekind (E) = E_Component
- and then Is_Protected_Private (E)
- then
- -- Protect against junk use of tasking in no run time mode
-
+ elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
end if;
- Expand_Protected_Private (N);
+ Expand_Protected_Component (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
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 not Is_LHS (N)
+ 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;
+
-- Interpret possible Current_Value for variable case
- if (Ekind (E) = E_Variable
- or else
- Ekind (E) = E_In_Out_Parameter
- or else
- Ekind (E) = E_Out_Parameter)
+ if Is_Assignable (E)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
-- Interpret possible Current_Value for constant case
- elsif (Ekind (E) = E_Constant
- or else
- Ekind (E) = E_In_Parameter
- or else
- Ekind (E) = E_Loop_Parameter)
+ elsif Is_Constant_Object (E)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
----------------------------------
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;
----------------------------
function In_Assignment_Context (N : Node_Id) return Boolean is
begin
- if Nkind (Parent (N)) = N_Procedure_Call_Statement
- or else Nkind (Parent (N)) = N_Entry_Call_Statement
- or else
- (Nkind (Parent (N)) = N_Assignment_Statement
- and then N = Name (Parent (N)))
+ -- 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));
- elsif (Nkind (Parent (N)) = N_Selected_Component
- or else Nkind (Parent (N)) = N_Indexed_Component
- or else Nkind (Parent (N)) = N_Slice)
+ -- 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;
-- 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);
+ Note_Possible_Modification (N, Sure => True);
end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), 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).
+ -- 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));
end if;
end Expand_N_Real_Literal;
- ------------------------------
- -- Expand_Protected_Private --
- ------------------------------
-
- 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 --
-- 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 or else Nkind (N) = N_Expanded_Name then
+ if Nkind_In (N, N_Identifier, N_Expanded_Name) then
if Is_Formal (Entity (N)) then
return Entity (N);
- elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
- and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
- 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
OSDN Git Service
