From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/exp_ch2.adb | 744 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 744 insertions(+) create mode 100644 gcc/ada/exp_ch2.adb (limited to 'gcc/ada/exp_ch2.adb') diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb new file mode 100644 index 000000000..e0be4042f --- /dev/null +++ b/gcc/ada/exp_ch2.adb @@ -0,0 +1,744 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ C H 2 -- +-- -- +-- B o d y -- +-- -- +-- 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 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +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 Sinput; use Sinput; +with Snames; use Snames; +with Tbuild; use Tbuild; +with Uintp; use Uintp; + +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 + -- of the initialization procedure for the type that is associated with + -- that particular discriminant. This replacement is not performed for + -- 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 + -- 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 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. + + 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 no-op. + + 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 + -- 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 + (Attribute_Name (Parent (N)) = Name_Asm_Input + or else + Attribute_Name (Parent (N)) = 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 a conditional 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 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)))); + end if; + + Analyze_And_Resolve (N, T); + Set_Is_Static_Expression (N, False); + end if; + end Expand_Current_Value; + + ------------------------- + -- Expand_Discriminant -- + ------------------------- + + procedure Expand_Discriminant (N : Node_Id) is + Scop : constant Entity_Id := Scope (Entity (N)); + P : Node_Id := N; + Parent_P : Node_Id := Parent (P); + In_Entry : Boolean := False; + + begin + -- The Incomplete_Or_Private_Kind happens while resolving the + -- discriminant constraint involved in a derived full type, + -- such as: + + -- type D is private; + -- type D(C : ...) is new T(C); + + 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 + + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Component_Declaration + loop + P := Parent_P; + Parent_P := Parent (P); + end loop; + + -- If the discriminant reference was part of the default expression + -- it has to be "discriminalized" + + if Present (Parent_P) and then P = Expression (Parent_P) then + Set_Entity (N, Discriminal (Entity (N))); + end if; + + elsif Is_Concurrent_Type (Scop) then + while Present (Parent_P) + and then Nkind (Parent_P) /= N_Subprogram_Body + loop + P := Parent_P; + + if Nkind (P) = N_Entry_Declaration then + In_Entry := True; + end if; + + Parent_P := Parent (Parent_P); + end loop; + + -- 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 : 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 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)) + then + Disc := CR_Discriminant (Entity (N)); + + New_N := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Formal, Loc), + Selector_Name => New_Occurrence_Of (Disc, Loc)); + + Set_Etype (New_N, Etype (N)); + Rewrite (N, New_N); + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end; + + elsif Nkind (Parent (N)) = N_Range + 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; + + else + Set_Entity (N, Discriminal (Entity (N))); + end if; + end Expand_Discriminant; + + ----------------------------- + -- Expand_Entity_Reference -- + ----------------------------- + + procedure Expand_Entity_Reference (N : Node_Id) is + E : constant Entity_Id := Entity (N); + + begin + -- Defend against errors + + if No (E) and then Total_Errors_Detected /= 0 then + return; + end if; + + if Ekind (E) = E_Discriminant then + Expand_Discriminant (N); + + elsif Is_Entry_Formal (E) then + Expand_Entry_Parameter (N); + + elsif Is_Protected_Component (E) then + if No_Run_Time_Mode then + return; + end if; + + Expand_Protected_Component (N); + + elsif Ekind (E) = E_Entry_Index_Parameter then + Expand_Entry_Index_Parameter (N); + + elsif Is_Formal (E) then + Expand_Formal (N); + + elsif Is_Renaming_Of_Object (E) then + Expand_Renaming (N); + + elsif Ekind (E) = E_Variable + and then Is_Shared_Passive (E) + 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 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 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; + + ---------------------------------- + -- Expand_Entry_Index_Parameter -- + ---------------------------------- + + procedure Expand_Entry_Index_Parameter (N : Node_Id) is + Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); + begin + Set_Entity (N, Index_Con); + Set_Etype (N, Etype (Index_Con)); + end Expand_Entry_Index_Parameter; + + ---------------------------- + -- Expand_Entry_Parameter -- + ---------------------------- + + procedure Expand_Entry_Parameter (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Ent_Formal : constant Entity_Id := Entity (N); + Ent_Spec : constant Entity_Id := Scope (Ent_Formal); + Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); + Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); + 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; + + Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); + return; + 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. + + P_Comp_Ref := + Make_Selected_Component (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (Parm_Type, + New_Reference_To (Addr_Ent, Loc))), + Selector_Name => + New_Reference_To (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 dereference is + -- implicit, but no harm is done by making it explicit). + + Rewrite (N, + Make_Explicit_Dereference (Loc, P_Comp_Ref)); + + Analyze (N); + end Expand_Entry_Parameter; + + ------------------- + -- Expand_Formal -- + ------------------- + + procedure Expand_Formal (N : Node_Id) is + E : constant Entity_Id := Entity (N); + Scop : constant Entity_Id := Scope (E); + + begin + -- 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)); + end if; + end Expand_Formal; + + ---------------------------- + -- Expand_N_Expanded_Name -- + ---------------------------- + + procedure Expand_N_Expanded_Name (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Expanded_Name; + + ------------------------- + -- Expand_N_Identifier -- + ------------------------- + + procedure Expand_N_Identifier (N : Node_Id) is + begin + Expand_Entity_Reference (N); + end Expand_N_Identifier; + + --------------------------- + -- Expand_N_Real_Literal -- + --------------------------- + + procedure Expand_N_Real_Literal (N : Node_Id) is + begin + if Vax_Float (Etype (N)) then + Expand_Vax_Real_Literal (N); + end if; + end Expand_N_Real_Literal; + + -------------------------------- + -- Expand_Protected_Component -- + -------------------------------- + + procedure Expand_Protected_Component (N : Node_Id) is + + function Inside_Eliminated_Body return Boolean; + -- Determine whether the current entity is inside a subprogram or an + -- entry which has been marked as eliminated. + + ---------------------------- + -- Inside_Eliminated_Body -- + ---------------------------- + + function Inside_Eliminated_Body return Boolean is + S : Entity_Id := Current_Scope; + + 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 + return True; + end if; + + S := Scope (S); + end loop; + + return False; + end Inside_Eliminated_Body; + + -- Start of processing for Expand_Protected_Component + + 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 -- + --------------------- + + procedure Expand_Renaming (N : Node_Id) is + E : constant Entity_Id := Entity (N); + T : constant Entity_Id := Etype (N); + + 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. + + Reset_Analyzed_Flags (N); + Analyze_And_Resolve (N, T); + end Expand_Renaming; + + ------------------ + -- Param_Entity -- + ------------------ + + -- 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. 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 + -- 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_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; + + begin + 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; + end if; + + return (Empty); + end Param_Entity; + +end Exp_Ch2; -- cgit v1.2.3