152419Sjulian------------------------------------------------------------------------------ 252419Sjulian-- -- 3139823Simp-- GNAT COMPILER COMPONENTS -- 4139823Simp-- -- 5139823Simp-- E X P _ C H 2 -- 652419Sjulian-- -- 752419Sjulian-- B o d y -- 870700Sjulian-- -- 952419Sjulian-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- 1052419Sjulian-- -- 1152419Sjulian-- GNAT is free software; you can redistribute it and/or modify it under -- 1252419Sjulian-- terms of the GNU General Public License as published by the Free Soft- -- 1352419Sjulian-- ware Foundation; either version 3, or (at your option) any later ver- -- 1452419Sjulian-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 1552419Sjulian-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 1652419Sjulian-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 1752419Sjulian-- for more details. You should have received a copy of the GNU General -- 1852419Sjulian-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 1970700Sjulian-- http://www.gnu.org/licenses for a complete copy of the license. -- 2052419Sjulian-- -- 2152419Sjulian-- GNAT was originally developed by the GNAT team at New York University. -- 2252419Sjulian-- Extensive contributions were provided by Ada Core Technologies Inc. -- 2352419Sjulian-- -- 2452419Sjulian------------------------------------------------------------------------------ 2552419Sjulian 2652419Sjulianwith Atree; use Atree; 2752419Sjulianwith Checks; use Checks; 2852419Sjulianwith Debug; use Debug; 2952419Sjulianwith Einfo; use Einfo; 3052419Sjulianwith Elists; use Elists; 3152419Sjulianwith Exp_Smem; use Exp_Smem; 3252419Sjulianwith Exp_Tss; use Exp_Tss; 3352419Sjulianwith Exp_Util; use Exp_Util; 3452419Sjulianwith Namet; use Namet; 3552419Sjulianwith Nmake; use Nmake; 3652419Sjulianwith Opt; use Opt; 3752419Sjulianwith Output; use Output; 3867506Sjulianwith Sem; use Sem; 3967506Sjulianwith Sem_Eval; use Sem_Eval; 4052419Sjulianwith Sem_Res; use Sem_Res; 4152419Sjulianwith Sem_Util; use Sem_Util; 4252419Sjulianwith Sem_Warn; use Sem_Warn; 4352419Sjulianwith Sinfo; use Sinfo; 4452419Sjulianwith Sinput; use Sinput; 4552419Sjulianwith Snames; use Snames; 4652419Sjulianwith Tbuild; use Tbuild; 4752419Sjulian 4852419Sjulianpackage body Exp_Ch2 is 4952419Sjulian 50139236Sglebius ----------------------- 51139235Sglebius -- Local Subprograms -- 5252419Sjulian ----------------------- 53131933Smarcel 5452419Sjulian procedure Expand_Current_Value (N : Node_Id); 55114216Skan -- N is a node for a variable whose Current_Value field is set. If N is 5652419Sjulian -- node is for a discrete type, replaces node with a copy of the referenced 57139235Sglebius -- value. This provides a limited form of value propagation for variables 5852419Sjulian -- which are initialized or assigned not been further modified at the time 5972946Sjulian -- of reference. The call has no effect if the Current_Value refers to a 60139235Sglebius -- conditional with condition other than equality. 6152419Sjulian 6252419Sjulian procedure Expand_Discriminant (N : Node_Id); 6352419Sjulian -- An occurrence of a discriminant within a discriminated type is replaced 6452419Sjulian -- with the corresponding discriminal, that is to say the formal parameter 6552419Sjulian -- of the initialization procedure for the type that is associated with 6653913Sarchie -- that particular discriminant. This replacement is not performed for 6752419Sjulian -- discriminants of records that appear in constraints of component of the 6872053Sjulian -- record, because Gigi uses the discriminant name to retrieve its value. 6959756Speter -- In the other hand, it has to be performed for default expressions of 7070784Sjulian -- components because they are used in the record init procedure. See Einfo 7170700Sjulian -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For 7270700Sjulian -- discriminants of tasks and protected types, the transformation is more 7352419Sjulian -- complex when it occurs within a default expression for an entry or 74122110Sharti -- protected operation. The corresponding default_expression_function has 75122110Sharti -- an additional parameter which is the target of an entry call, and the 76122110Sharti -- discriminant of the task must be replaced with a reference to the 7770784Sjulian -- discriminant of that formal parameter. 7870784Sjulian 7970784Sjulian procedure Expand_Entity_Reference (N : Node_Id); 8070784Sjulian -- Common processing for expansion of identifiers and expanded names 8170784Sjulian -- Dispatches to specific expansion procedures. 8270784Sjulian 8370784Sjulian procedure Expand_Entry_Index_Parameter (N : Node_Id); 8470784Sjulian -- A reference to the identifier in the entry index specification of an 8570784Sjulian -- entry body is modified to a reference to a constant definition equal to 8670784Sjulian -- the index of the entry family member being called. This constant is 8770784Sjulian -- calculated as part of the elaboration of the expanded code for the body, 8870784Sjulian -- and is calculated from the object-wide entry index returned by Next_ 8970935Sjulian -- Entry_Call. 9070935Sjulian 9170935Sjulian procedure Expand_Entry_Parameter (N : Node_Id); 9270935Sjulian -- A reference to an entry parameter is modified to be a reference to the 9370935Sjulian -- corresponding component of the entry parameter record that is passed by 9470935Sjulian -- the runtime to the accept body procedure. 9570935Sjulian 9670935Sjulian procedure Expand_Formal (N : Node_Id); 9770935Sjulian -- A reference to a formal parameter of a protected subprogram is expanded 9870935Sjulian -- into the corresponding formal of the unprotected procedure used to 9970935Sjulian -- represent the operation within the protected object. In other cases 10070935Sjulian -- Expand_Formal is a no-op. 10170935Sjulian 10270935Sjulian procedure Expand_Protected_Component (N : Node_Id); 10370935Sjulian -- A reference to a private component of a protected type is expanded into 10470935Sjulian -- a reference to the corresponding prival in the current protected entry 10570935Sjulian -- or subprogram. 10670935Sjulian 10770935Sjulian procedure Expand_Renaming (N : Node_Id); 10870935Sjulian -- For renamings, just replace the identifier by the corresponding 10970784Sjulian -- named expression. Note that this has been evaluated (see routine 11070935Sjulian -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives 11170935Sjulian -- the correct renaming semantics. 11270935Sjulian 113132464Sjulian -------------------------- 11470935Sjulian -- Expand_Current_Value -- 11570935Sjulian -------------------------- 11670935Sjulian 11770935Sjulian procedure Expand_Current_Value (N : Node_Id) is 11870935Sjulian Loc : constant Source_Ptr := Sloc (N); 11970935Sjulian E : constant Entity_Id := Entity (N); 12070935Sjulian CV : constant Node_Id := Current_Value (E); 12170935Sjulian T : constant Entity_Id := Etype (N); 12270935Sjulian Val : Node_Id; 12370935Sjulian Op : Node_Kind; 12470935Sjulian 12570935Sjulian -- Start of processing for Expand_Current_Value 12670935Sjulian 12770935Sjulian begin 12870935Sjulian if True 12970935Sjulian 13070935Sjulian -- No replacement if value raises constraint error 13170935Sjulian 13270935Sjulian and then Nkind (CV) /= N_Raise_Constraint_Error 13370935Sjulian 13470935Sjulian -- Do this only for discrete types 13570935Sjulian 13670935Sjulian and then Is_Discrete_Type (T) 13770935Sjulian 13870935Sjulian -- Do not replace biased types, since it is problematic to 13970935Sjulian -- consistently generate a sensible constant value in this case. 14070935Sjulian 14170935Sjulian and then not Has_Biased_Representation (T) 14270935Sjulian 14370935Sjulian -- Do not replace lvalues 14471885Sjulian 14571885Sjulian and then not May_Be_Lvalue (N) 14670935Sjulian 14770935Sjulian -- Check that entity is suitable for replacement 14870935Sjulian 14970935Sjulian and then OK_To_Do_Constant_Replacement (E) 15070935Sjulian 15170935Sjulian -- Do not replace occurrences in pragmas (where names typically 15270935Sjulian -- appear not as values, but as simply names. If there are cases 15370935Sjulian -- where values are required, it is only a very minor efficiency 15470935Sjulian -- issue that they do not get replaced when they could be). 15570935Sjulian 15670935Sjulian and then Nkind (Parent (N)) /= N_Pragma_Argument_Association 15770700Sjulian 15870700Sjulian -- Do not replace the prefixes of attribute references, since this 15971902Sjulian -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and 16070700Sjulian -- Name_Asm_Output, don't do replacement anywhere, since we can have 16152419Sjulian -- lvalue references in the arguments. 16270700Sjulian 16370700Sjulian and then not (Nkind (Parent (N)) = N_Attribute_Reference 16452419Sjulian and then 16570700Sjulian (Nam_In (Attribute_Name (Parent (N)), 16671354Sjulian Name_Asm_Input, 16771354Sjulian Name_Asm_Output) 16871354Sjulian or else Prefix (Parent (N)) = N)) 16970700Sjulian 17071354Sjulian then 17171354Sjulian -- Case of Current_Value is a compile time known value 17271354Sjulian 17371354Sjulian if Nkind (CV) in N_Subexpr then 174131008Srwatson Val := CV; 17571354Sjulian 17671354Sjulian -- Case of Current_Value is an if expression reference 17771354Sjulian 17871354Sjulian else 17971354Sjulian Get_Current_Value_Condition (N, Op, Val); 18071354Sjulian 18171354Sjulian if Op /= N_Op_Eq then 18271354Sjulian return; 18352722Sjulian end if; 18470700Sjulian end if; 18552419Sjulian 18652419Sjulian -- If constant value is an occurrence of an enumeration literal, 18770700Sjulian -- then we just make another occurrence of the same literal. 18852722Sjulian 18952419Sjulian if Is_Entity_Name (Val) 19070700Sjulian and then Ekind (Entity (Val)) = E_Enumeration_Literal 19152419Sjulian then 19274078Sjulian Rewrite (N, 19370700Sjulian Unchecked_Convert_To (T, 19470700Sjulian New_Occurrence_Of (Entity (Val), Loc))); 19570700Sjulian 19671047Sjulian -- If constant is of an integer type, just make an appropriately 19771047Sjulian -- integer literal, which will get the proper type. 19871849Sjulian 19971849Sjulian elsif Is_Integer_Type (T) then 20071047Sjulian Rewrite (N, 20171047Sjulian Make_Integer_Literal (Loc, 20252419Sjulian Intval => Expr_Rep_Value (Val))); 20370784Sjulian 20470700Sjulian -- Otherwise do unchecked conversion of value to right type 20570700Sjulian 20670700Sjulian else 20770700Sjulian Rewrite (N, 20870700Sjulian Unchecked_Convert_To (T, 20970700Sjulian Make_Integer_Literal (Loc, 21071849Sjulian Intval => Expr_Rep_Value (Val)))); 21170784Sjulian end if; 21270700Sjulian 21370700Sjulian Analyze_And_Resolve (N, T); 21452419Sjulian Set_Is_Static_Expression (N, False); 21552419Sjulian end if; 21670700Sjulian end Expand_Current_Value; 21770700Sjulian 21870700Sjulian ------------------------- 21970700Sjulian -- Expand_Discriminant -- 22052419Sjulian ------------------------- 22170700Sjulian 22270784Sjulian procedure Expand_Discriminant (N : Node_Id) is 22370784Sjulian Scop : constant Entity_Id := Scope (Entity (N)); 22470784Sjulian P : Node_Id := N; 22570784Sjulian Parent_P : Node_Id := Parent (P); 22670784Sjulian In_Entry : Boolean := False; 22770784Sjulian 22870784Sjulian begin 22970784Sjulian -- The Incomplete_Or_Private_Kind happens while resolving the 23070784Sjulian -- discriminant constraint involved in a derived full type, 23170784Sjulian -- such as: 23270784Sjulian 23370784Sjulian -- type D is private; 23470784Sjulian -- type D(C : ...) is new T(C); 23570784Sjulian 23670784Sjulian if Ekind (Scop) = E_Record_Type 23770784Sjulian or Ekind (Scop) in Incomplete_Or_Private_Kind 23870784Sjulian then 23970784Sjulian -- Find the origin by walking up the tree till the component 24070784Sjulian -- declaration 24170784Sjulian 24272200Sbmilekic while Present (Parent_P) 24370784Sjulian and then Nkind (Parent_P) /= N_Component_Declaration 24470784Sjulian loop 24570784Sjulian P := Parent_P; 24670784Sjulian Parent_P := Parent (P); 24770784Sjulian end loop; 24870784Sjulian 24972200Sbmilekic -- If the discriminant reference was part of the default expression 25070784Sjulian -- it has to be "discriminalized" 25170784Sjulian 25272200Sbmilekic if Present (Parent_P) and then P = Expression (Parent_P) then 25370784Sjulian Set_Entity (N, Discriminal (Entity (N))); 25470784Sjulian end if; 25570784Sjulian 25672200Sbmilekic elsif Is_Concurrent_Type (Scop) then 25770784Sjulian while Present (Parent_P) 25872200Sbmilekic and then Nkind (Parent_P) /= N_Subprogram_Body 25970784Sjulian loop 26070784Sjulian P := Parent_P; 26170784Sjulian 26270784Sjulian if Nkind (P) = N_Entry_Declaration then 26370784Sjulian In_Entry := True; 26470784Sjulian end if; 26570784Sjulian 26670784Sjulian Parent_P := Parent (Parent_P); 26770784Sjulian end loop; 26870784Sjulian 26972200Sbmilekic -- If the discriminant occurs within the default expression for a 27070784Sjulian -- formal of an entry or protected operation, replace it with a 27170784Sjulian -- reference to the discriminant of the formal of the enclosing 27270784Sjulian -- operation. 27370784Sjulian 27470784Sjulian if Present (Parent_P) 27570784Sjulian and then Present (Corresponding_Spec (Parent_P)) 27672200Sbmilekic then 27770784Sjulian declare 27870784Sjulian Loc : constant Source_Ptr := Sloc (N); 27972200Sbmilekic D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P); 28070784Sjulian Formal : constant Entity_Id := First_Formal (D_Fun); 28170784Sjulian New_N : Node_Id; 28270784Sjulian Disc : Entity_Id; 28372200Sbmilekic 28470784Sjulian begin 28572200Sbmilekic -- Verify that we are within the body of an entry or protected 28670784Sjulian -- operation. Its first formal parameter is the synchronized 28770784Sjulian -- type itself. 28870784Sjulian 28970784Sjulian if Present (Formal) 29070784Sjulian and then Etype (Formal) = Scope (Entity (N)) 29170784Sjulian then 29270784Sjulian Disc := CR_Discriminant (Entity (N)); 29370784Sjulian 29470784Sjulian New_N := 29570784Sjulian Make_Selected_Component (Loc, 29670784Sjulian Prefix => New_Occurrence_Of (Formal, Loc), 29772200Sbmilekic Selector_Name => New_Occurrence_Of (Disc, Loc)); 29870784Sjulian 29970784Sjulian Set_Etype (New_N, Etype (N)); 30072200Sbmilekic Rewrite (N, New_N); 30170784Sjulian 30270784Sjulian else 30370784Sjulian Set_Entity (N, Discriminal (Entity (N))); 30470784Sjulian end if; 30572200Sbmilekic end; 30670784Sjulian 30770784Sjulian elsif Nkind (Parent (N)) = N_Range 30872200Sbmilekic and then In_Entry 30970784Sjulian then 31070784Sjulian Set_Entity (N, CR_Discriminant (Entity (N))); 31170784Sjulian 31270784Sjulian -- Finally, if the entity is the discriminant of the original 31370784Sjulian -- type declaration, and we are within the initialization 31470784Sjulian -- procedure for a task, the designated entity is the 31570784Sjulian -- discriminal of the task body. This can happen when the 31670700Sjulian -- argument of pragma Task_Name mentions a discriminant, 31770700Sjulian -- because the pragma is analyzed in the task declaration 31870784Sjulian -- but is expanded in the call to Create_Task in the init_proc. 31970784Sjulian 32070784Sjulian elsif Within_Init_Proc then 32170700Sjulian Set_Entity (N, Discriminal (CR_Discriminant (Entity (N)))); 32270700Sjulian else 32370700Sjulian Set_Entity (N, Discriminal (Entity (N))); 32470700Sjulian end if; 325131933Smarcel 32652419Sjulian else 32771047Sjulian Set_Entity (N, Discriminal (Entity (N))); 32852419Sjulian end if; 32952419Sjulian end Expand_Discriminant; 33052722Sjulian 33152722Sjulian ----------------------------- 33253403Sarchie -- Expand_Entity_Reference -- 33353403Sarchie ----------------------------- 33453403Sarchie 33553403Sarchie procedure Expand_Entity_Reference (N : Node_Id) is 33653403Sarchie E : constant Entity_Id := Entity (N); 337113255Sdes 33853403Sarchie begin 33953403Sarchie -- Defend against errors 34053403Sarchie 34153403Sarchie if No (E) then 34287599Sobrien Check_Error_Detected; 34353403Sarchie return; 34453403Sarchie end if; 34553403Sarchie 34653403Sarchie if Ekind (E) = E_Discriminant then 34753403Sarchie Expand_Discriminant (N); 34852722Sjulian 34953403Sarchie elsif Is_Entry_Formal (E) then 35052419Sjulian Expand_Entry_Parameter (N); 35153913Sarchie 35253913Sarchie elsif Is_Protected_Component (E) then 35353913Sarchie if No_Run_Time_Mode then 35453913Sarchie return; 35553913Sarchie else 35697685Sarchie Expand_Protected_Component (N); 35797685Sarchie end if; 35853913Sarchie 35953913Sarchie elsif Ekind (E) = E_Entry_Index_Parameter then 36097685Sarchie Expand_Entry_Index_Parameter (N); 36153913Sarchie 36253913Sarchie elsif Is_Formal (E) then 36353913Sarchie Expand_Formal (N); 36453913Sarchie 36553913Sarchie elsif Is_Renaming_Of_Object (E) then 36653913Sarchie Expand_Renaming (N); 36753913Sarchie 36853913Sarchie elsif Ekind (E) = E_Variable 36953913Sarchie and then Is_Shared_Passive (E) 37053913Sarchie then 37153913Sarchie Expand_Shared_Passive_Variable (N); 37272645Sasmodai end if; 37353913Sarchie 37453913Sarchie -- Test code for implementing the pragma Reviewable requirement of 37553913Sarchie -- classifying reads of scalars as referencing potentially uninitialized 37653913Sarchie -- objects or not. 37753913Sarchie 37853913Sarchie if Debug_Flag_XX 37953913Sarchie and then Is_Scalar_Type (Etype (N)) 38053913Sarchie and then (Is_Assignable (E) or else Is_Constant_Object (E)) 38153913Sarchie and then Comes_From_Source (N) 38253913Sarchie and then Is_LHS (N) = No 38353913Sarchie and then not Is_Actual_Out_Parameter (N) 38453913Sarchie and then (Nkind (Parent (N)) /= N_Attribute_Reference 38553913Sarchie or else Attribute_Name (Parent (N)) /= Name_Valid) 38653913Sarchie then 38753913Sarchie Write_Location (Sloc (N)); 38853913Sarchie Write_Str (": Read from scalar """); 38953913Sarchie Write_Name (Chars (N)); 39053913Sarchie Write_Str (""""); 39153913Sarchie 39253913Sarchie if Is_Known_Valid (E) then 39353913Sarchie Write_Str (", Is_Known_Valid"); 39453913Sarchie end if; 39553913Sarchie 39653913Sarchie Write_Eol; 39753913Sarchie end if; 39853913Sarchie 39953913Sarchie -- Set Atomic_Sync_Required if necessary for atomic variable 40053913Sarchie 40153913Sarchie if Nkind_In (N, N_Identifier, N_Expanded_Name) 40253913Sarchie and then Ekind (E) = E_Variable 40353913Sarchie and then (Is_Atomic (E) or else Is_Atomic (Etype (E))) 40453913Sarchie then 40553913Sarchie declare 40653913Sarchie Set : Boolean; 40753913Sarchie 40853913Sarchie begin 40953913Sarchie -- If variable is atomic, but type is not, setting depends on 41053913Sarchie -- disable/enable state for the variable. 41153913Sarchie 41253913Sarchie if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then 41353913Sarchie Set := not Atomic_Synchronization_Disabled (E); 41453913Sarchie 41553913Sarchie -- If variable is not atomic, but its type is atomic, setting 41653913Sarchie -- depends on disable/enable state for the type. 41753913Sarchie 41853913Sarchie elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then 41953913Sarchie Set := not Atomic_Synchronization_Disabled (Etype (E)); 42053913Sarchie 42153913Sarchie -- Else both variable and type are atomic (see outer if), and we 42253913Sarchie -- disable if either variable or its type have sync disabled. 42353913Sarchie 42453913Sarchie else 42553913Sarchie Set := (not Atomic_Synchronization_Disabled (E)) 42653913Sarchie and then 42753913Sarchie (not Atomic_Synchronization_Disabled (Etype (E))); 42853913Sarchie end if; 42953913Sarchie 43053913Sarchie -- Set flag if required 43153913Sarchie 43253913Sarchie if Set then 43353913Sarchie Activate_Atomic_Synchronization (N); 43453913Sarchie end if; 43553913Sarchie end; 43653913Sarchie end if; 43753913Sarchie 43853913Sarchie -- Interpret possible Current_Value for variable case 43953913Sarchie 44053913Sarchie if Is_Assignable (E) 44153913Sarchie and then Present (Current_Value (E)) 44253913Sarchie then 44353913Sarchie Expand_Current_Value (N); 44453913Sarchie 44553913Sarchie -- We do want to warn for the case of a boolean variable (not a 44653913Sarchie -- boolean constant) whose value is known at compile time. 44753913Sarchie 44853913Sarchie if Is_Boolean_Type (Etype (N)) then 44953913Sarchie Warn_On_Known_Condition (N); 45053913Sarchie end if; 45153913Sarchie 45253913Sarchie -- Don't mess with Current_Value for compile time known values. Not 45353913Sarchie -- only is it unnecessary, but we could disturb an indication of a 45453913Sarchie -- static value, which could cause semantic trouble. 45553913Sarchie 45653913Sarchie elsif Compile_Time_Known_Value (N) then 45753913Sarchie null; 45853913Sarchie 45953913Sarchie -- Interpret possible Current_Value for constant case 46053913Sarchie 46153913Sarchie elsif Is_Constant_Object (E) 46253913Sarchie and then Present (Current_Value (E)) 46353913Sarchie then 46453913Sarchie Expand_Current_Value (N); 46553913Sarchie end if; 46653913Sarchie end Expand_Entity_Reference; 46753913Sarchie 46853913Sarchie ---------------------------------- 46953913Sarchie -- Expand_Entry_Index_Parameter -- 47053913Sarchie ---------------------------------- 47153913Sarchie 47253913Sarchie procedure Expand_Entry_Index_Parameter (N : Node_Id) is 47353913Sarchie Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N)); 47453913Sarchie begin 47553913Sarchie Set_Entity (N, Index_Con); 47653913Sarchie Set_Etype (N, Etype (Index_Con)); 47753913Sarchie end Expand_Entry_Index_Parameter; 47853913Sarchie 47953913Sarchie ---------------------------- 48053913Sarchie -- Expand_Entry_Parameter -- 48153913Sarchie ---------------------------- 48253913Sarchie 48353913Sarchie procedure Expand_Entry_Parameter (N : Node_Id) is 48453913Sarchie Loc : constant Source_Ptr := Sloc (N); 48553913Sarchie Ent_Formal : constant Entity_Id := Entity (N); 48653913Sarchie Ent_Spec : constant Entity_Id := Scope (Ent_Formal); 48753913Sarchie Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec); 48853913Sarchie Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec); 48953913Sarchie Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack)); 49053913Sarchie P_Comp_Ref : Entity_Id; 49153913Sarchie 49253913Sarchie function In_Assignment_Context (N : Node_Id) return Boolean; 49353913Sarchie -- Check whether this is a context in which the entry formal may be 49453913Sarchie -- assigned to. 49553913Sarchie 49653913Sarchie --------------------------- 49753913Sarchie -- In_Assignment_Context -- 49853913Sarchie --------------------------- 49953913Sarchie 50053913Sarchie function In_Assignment_Context (N : Node_Id) return Boolean is 50162471Sphk begin 50262471Sphk -- Case of use in a call 50362471Sphk 50462471Sphk -- ??? passing a formal as actual for a mode IN formal is 50562471Sphk -- considered as an assignment? 50662471Sphk 50762471Sphk if Nkind_In (Parent (N), N_Procedure_Call_Statement, 50853913Sarchie N_Entry_Call_Statement) 50953913Sarchie or else (Nkind (Parent (N)) = N_Assignment_Statement 51053913Sarchie and then N = Name (Parent (N))) 51153913Sarchie then 51253913Sarchie return True; 51353913Sarchie 51453913Sarchie -- Case of a parameter association: climb up to enclosing call 51553913Sarchie 51653913Sarchie elsif Nkind (Parent (N)) = N_Parameter_Association then 51753913Sarchie return In_Assignment_Context (Parent (N)); 51853913Sarchie 51953913Sarchie -- Case of a selected component, indexed component or slice prefix: 52053913Sarchie -- climb up the tree, unless the prefix is of an access type (in 52153913Sarchie -- which case there is an implicit dereference, and the formal itself 52253913Sarchie -- is not being assigned to). 52353913Sarchie 52453913Sarchie elsif Nkind_In (Parent (N), N_Selected_Component, 52553913Sarchie N_Indexed_Component, 52653913Sarchie N_Slice) 52753913Sarchie and then N = Prefix (Parent (N)) 52853913Sarchie and then not Is_Access_Type (Etype (N)) 52953913Sarchie and then In_Assignment_Context (Parent (N)) 53053913Sarchie then 53152419Sjulian return True; 53252419Sjulian 53352419Sjulian else 53452419Sjulian return False; 53552419Sjulian end if; 53652419Sjulian end In_Assignment_Context; 53752419Sjulian 53852419Sjulian -- Start of processing for Expand_Entry_Parameter 53952419Sjulian 54052419Sjulian begin 54170700Sjulian if Is_Task_Type (Scope (Ent_Spec)) 54252419Sjulian and then Comes_From_Source (Ent_Formal) 54352419Sjulian then 54452419Sjulian -- Before replacing the formal with the local renaming that is used 54571047Sjulian -- in the accept block, note if this is an assignment context, and 54652419Sjulian -- note the modification to avoid spurious warnings, because the 54752419Sjulian -- original entity is not used further. If formal is unconstrained, 54852419Sjulian -- we also generate an extra parameter to hold the Constrained 549132705Sglebius -- attribute of the actual. No renaming is generated for this flag. 550132705Sglebius 551132705Sglebius -- Calling Note_Possible_Modification in the expander is dubious, 552132705Sglebius -- because this generates a cross-reference entry, and should be 553132705Sglebius -- done during semantic processing so it is called in -gnatc mode??? 55452419Sjulian 55570700Sjulian if Ekind (Entity (N)) /= E_In_Parameter 55670700Sjulian and then In_Assignment_Context (N) 55770700Sjulian then 55870700Sjulian Note_Possible_Modification (N, Sure => True); 55970700Sjulian end if; 56070700Sjulian end if; 56170700Sjulian 56270784Sjulian -- What we need is a reference to the corresponding component of the 56370700Sjulian -- parameter record object. The Accept_Address field of the entry entity 56470700Sjulian -- references the address variable that contains the address of the 56570700Sjulian -- accept parameters record. We first have to do an unchecked conversion 56670700Sjulian -- to turn this into a pointer to the parameter record and then we 56770700Sjulian -- select the required parameter field. 56870700Sjulian 56970935Sjulian -- The same processing applies to protected entries, where the Accept_ 57070700Sjulian -- Address is also the address of the Parameters record. 57170700Sjulian 57270700Sjulian P_Comp_Ref := 57371047Sjulian Make_Selected_Component (Loc, 57470700Sjulian Prefix => 57570700Sjulian Make_Explicit_Dereference (Loc, 57670700Sjulian Unchecked_Convert_To (Parm_Type, 57752419Sjulian New_Occurrence_Of (Addr_Ent, Loc))), 57852419Sjulian Selector_Name => 57952419Sjulian New_Occurrence_Of (Entry_Component (Ent_Formal), Loc)); 58070700Sjulian 58170700Sjulian -- For all types of parameters, the constructed parameter record object 58252419Sjulian -- contains a pointer to the parameter. Thus we must dereference them to 58352419Sjulian -- access them (this will often be redundant, since the dereference is 58452419Sjulian -- implicit, but no harm is done by making it explicit). 58552419Sjulian 58652419Sjulian Rewrite (N, 58752419Sjulian Make_Explicit_Dereference (Loc, P_Comp_Ref)); 58852419Sjulian 58952419Sjulian Analyze (N); 59052419Sjulian end Expand_Entry_Parameter; 59171047Sjulian 59252419Sjulian ------------------- 59352419Sjulian -- Expand_Formal -- 59452419Sjulian ------------------- 59552419Sjulian 59670784Sjulian procedure Expand_Formal (N : Node_Id) is 59752419Sjulian E : constant Entity_Id := Entity (N); 59871047Sjulian Scop : constant Entity_Id := Scope (E); 59952419Sjulian 60052419Sjulian begin 60170784Sjulian -- Check whether the subprogram of which this is a formal is 60270784Sjulian -- a protected operation. The initialization procedure for 60352419Sjulian -- the corresponding record type is not itself a protected operation. 60452419Sjulian 60593818Sjhb if Is_Protected_Type (Scope (Scop)) 60670784Sjulian and then not Is_Init_Proc (Scop) 60770784Sjulian and then Present (Protected_Formal (E)) 60870784Sjulian then 60970784Sjulian Set_Entity (N, Protected_Formal (E)); 61052419Sjulian end if; 61152419Sjulian end Expand_Formal; 61270784Sjulian 61352419Sjulian ---------------------------- 61470700Sjulian -- Expand_N_Expanded_Name -- 61572200Sbmilekic ---------------------------- 61670784Sjulian 61772200Sbmilekic procedure Expand_N_Expanded_Name (N : Node_Id) is 61870700Sjulian begin 61970700Sjulian Expand_Entity_Reference (N); 62052722Sjulian end Expand_N_Expanded_Name; 62172200Sbmilekic 62270784Sjulian ------------------------- 62370700Sjulian -- Expand_N_Identifier -- 62470784Sjulian ------------------------- 62571354Sjulian 62670784Sjulian procedure Expand_N_Identifier (N : Node_Id) is 62771354Sjulian begin 62871354Sjulian Expand_Entity_Reference (N); 62970784Sjulian end Expand_N_Identifier; 63070700Sjulian 63170784Sjulian --------------------------- 63271354Sjulian -- Expand_N_Real_Literal -- 63370784Sjulian --------------------------- 63472200Sbmilekic 63552722Sjulian procedure Expand_N_Real_Literal (N : Node_Id) is 63652419Sjulian pragma Unreferenced (N); 63752419Sjulian 63852419Sjulian begin 63952419Sjulian -- Historically, this routine existed because there were expansion 64052419Sjulian -- requirements for Vax real literals, but now Vax real literals 64152419Sjulian -- are now handled by gigi, so this routine no longer does anything. 64252419Sjulian 64352419Sjulian null; 64452419Sjulian end Expand_N_Real_Literal; 64552419Sjulian 64670700Sjulian -------------------------------- 64770939Sjulian -- Expand_Protected_Component -- 64870939Sjulian -------------------------------- 64970700Sjulian 65070700Sjulian procedure Expand_Protected_Component (N : Node_Id) is 65170939Sjulian 65270939Sjulian function Inside_Eliminated_Body return Boolean; 65370939Sjulian -- Determine whether the current entity is inside a subprogram or an 65470939Sjulian -- entry which has been marked as eliminated. 65570939Sjulian 65670939Sjulian ---------------------------- 65770939Sjulian -- Inside_Eliminated_Body -- 65852419Sjulian ---------------------------- 65952419Sjulian 66071849Sjulian function Inside_Eliminated_Body return Boolean is 66152419Sjulian S : Entity_Id := Current_Scope; 66270939Sjulian 66370939Sjulian begin 66452419Sjulian while Present (S) loop 665132464Sjulian if (Ekind (S) = E_Entry 66652419Sjulian or else Ekind (S) = E_Entry_Family 66752419Sjulian or else Ekind (S) = E_Function 66871849Sjulian or else Ekind (S) = E_Procedure) 66971849Sjulian and then Is_Eliminated (S) 67071849Sjulian then 67171849Sjulian return True; 67271849Sjulian end if; 67352419Sjulian 67470784Sjulian S := Scope (S); 67552419Sjulian end loop; 67670784Sjulian 67770784Sjulian return False; 67870784Sjulian end Inside_Eliminated_Body; 679132464Sjulian 68070784Sjulian -- Start of processing for Expand_Protected_Component 68170784Sjulian 682132464Sjulian begin 68352419Sjulian -- Eliminated bodies are not expanded and thus do not need privals 684129836Sjulian 685129836Sjulian if not Inside_Eliminated_Body then 686129836Sjulian declare 687129836Sjulian Priv : constant Entity_Id := Prival (Entity (N)); 68870939Sjulian begin 68970939Sjulian Set_Entity (N, Priv); 69070939Sjulian Set_Etype (N, Etype (Priv)); 69170784Sjulian end; 69270700Sjulian end if; 69370700Sjulian end Expand_Protected_Component; 69470784Sjulian 69570784Sjulian --------------------- 69670784Sjulian -- Expand_Renaming -- 69771902Sjulian --------------------- 69870700Sjulian 69970784Sjulian procedure Expand_Renaming (N : Node_Id) is 70070700Sjulian E : constant Entity_Id := Entity (N); 70152419Sjulian T : constant Entity_Id := Etype (N); 70270784Sjulian 70370784Sjulian begin 70471849Sjulian Rewrite (N, New_Copy_Tree (Renamed_Object (E))); 70571849Sjulian 70671849Sjulian -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed 70771849Sjulian -- at the top level. This is needed in the packed case since we 70871849Sjulian -- specifically avoided expanding packed array references when the 70971849Sjulian -- renaming declaration was analyzed. 71071849Sjulian 711132464Sjulian Reset_Analyzed_Flags (N); 71271849Sjulian Analyze_And_Resolve (N, T); 713132464Sjulian end Expand_Renaming; 71471849Sjulian 71571849Sjulian ------------------ 71671849Sjulian -- Param_Entity -- 71770700Sjulian ------------------ 71870784Sjulian 71952419Sjulian -- This would be trivial, simply a test for an identifier that was a 72052419Sjulian -- reference to a formal, if it were not for the fact that a previous call 72170784Sjulian -- to Expand_Entry_Parameter will have modified the reference to the 72270784Sjulian -- identifier. A formal of a protected entity is rewritten as 72370784Sjulian 72470784Sjulian -- typ!(recobj).rec.all'Constrained 72570784Sjulian 72670784Sjulian -- where rec is a selector whose Entry_Formal link points to the formal 72770784Sjulian 72870784Sjulian -- If the type of the entry parameter has a representation clause, then an 72970784Sjulian -- extra temp is involved (see below). 73070784Sjulian 73152419Sjulian -- For a formal of a task entity, the formal is rewritten as a local 73252419Sjulian -- renaming. 73374078Sjulian 73474078Sjulian -- In addition, a formal that is marked volatile because it is aliased 73574078Sjulian -- through an address clause is rewritten as dereference as well. 73674078Sjulian 73774078Sjulian function Param_Entity (N : Node_Id) return Entity_Id is 73874078Sjulian Renamed_Obj : Node_Id; 73974078Sjulian 74074078Sjulian begin 74152419Sjulian -- Simple reference case 74274078Sjulian 74374078Sjulian if Nkind_In (N, N_Identifier, N_Expanded_Name) then 74452419Sjulian if Is_Formal (Entity (N)) then 74574078Sjulian return Entity (N); 74670784Sjulian 74752419Sjulian -- Handle renamings of formal parameters and formals of tasks that 74870784Sjulian -- are rewritten as renamings. 74971047Sjulian 75071047Sjulian elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then 75174078Sjulian Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); 75271047Sjulian 75371047Sjulian if Is_Entity_Name (Renamed_Obj) 75470784Sjulian and then Is_Formal (Entity (Renamed_Obj)) 75574078Sjulian then 75674078Sjulian return Entity (Renamed_Obj); 75769519Sjulian 75874078Sjulian elsif 75970700Sjulian Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement 76072200Sbmilekic then 76170784Sjulian return Entity (N); 76270784Sjulian end if; 76372200Sbmilekic end if; 76470700Sjulian 76572200Sbmilekic else 76670784Sjulian if Nkind (N) = N_Explicit_Dereference then 76772200Sbmilekic declare 76852419Sjulian P : Node_Id := Prefix (N); 76970791Sjulian S : Node_Id; 77070700Sjulian E : Entity_Id; 77152419Sjulian Decl : Node_Id; 77274078Sjulian 77352419Sjulian begin 77452419Sjulian -- If the type of an entry parameter has a representation 77552419Sjulian -- clause, then the prefix is not a selected component, but 77652722Sjulian -- instead a reference to a temp pointing at the selected 77752722Sjulian -- component. In this case, set P to be the initial value of 77852722Sjulian -- that temp. 77970700Sjulian 78052722Sjulian if Nkind (P) = N_Identifier then 78170784Sjulian E := Entity (P); 78272200Sbmilekic 78371354Sjulian if Ekind (E) = E_Constant then 78470784Sjulian Decl := Parent (E); 78570784Sjulian 78672200Sbmilekic if Nkind (Decl) = N_Object_Declaration then 78770784Sjulian P := Expression (Decl); 78852722Sjulian end if; 78952722Sjulian end if; 79052722Sjulian end if; 79152722Sjulian 79252722Sjulian if Nkind (P) = N_Selected_Component then 79370912Sjulian S := Selector_Name (P); 79452722Sjulian 79552722Sjulian if Present (Entry_Formal (Entity (S))) then 79652722Sjulian return Entry_Formal (Entity (S)); 79752419Sjulian end if; 79852419Sjulian 79952419Sjulian elsif Nkind (Original_Node (N)) = N_Identifier then 80052419Sjulian return Param_Entity (Original_Node (N)); 80152419Sjulian end if; 80252419Sjulian end; 80352419Sjulian end if; 80452419Sjulian end if; 80552419Sjulian 80652419Sjulian return (Empty); 80770700Sjulian end Param_Entity; 80852419Sjulian 80952419Sjulianend Exp_Ch2; 810125028Sharti