1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Errout; use Errout;
31 with Exp_Smem; use Exp_Smem;
32 with Exp_Tss; use Exp_Tss;
33 with Exp_Util; use Exp_Util;
34 with Exp_VFpt; use Exp_VFpt;
35 with Namet; use Namet;
36 with Nmake; use Nmake;
38 with Output; use Output;
40 with Sem_Eval; use Sem_Eval;
41 with Sem_Res; use Sem_Res;
42 with Sem_Util; use Sem_Util;
43 with Sem_Warn; use Sem_Warn;
44 with Sinfo; use Sinfo;
45 with Sinput; use Sinput;
46 with Snames; use Snames;
47 with Tbuild; use Tbuild;
48 with Uintp; use Uintp;
50 package body Exp_Ch2 is
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
56 procedure Expand_Current_Value (N : Node_Id);
57 -- N is a node for a variable whose Current_Value field is set. If N is
58 -- node is for a discrete type, replaces node with a copy of the referenced
59 -- value. This provides a limited form of value propagation for variables
60 -- which are initialized or assigned not been further modified at the time
61 -- of reference. The call has no effect if the Current_Value refers to a
62 -- conditional with condition other than equality.
64 procedure Expand_Discriminant (N : Node_Id);
65 -- An occurrence of a discriminant within a discriminated type is replaced
66 -- with the corresponding discriminal, that is to say the formal parameter
67 -- of the initialization procedure for the type that is associated with
68 -- that particular discriminant. This replacement is not performed for
69 -- discriminants of records that appear in constraints of component of the
70 -- record, because Gigi uses the discriminant name to retrieve its value.
71 -- In the other hand, it has to be performed for default expressions of
72 -- components because they are used in the record init procedure. See Einfo
73 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
74 -- discriminants of tasks and protected types, the transformation is more
75 -- complex when it occurs within a default expression for an entry or
76 -- protected operation. The corresponding default_expression_function has
77 -- an additional parameter which is the target of an entry call, and the
78 -- discriminant of the task must be replaced with a reference to the
79 -- discriminant of that formal parameter.
81 procedure Expand_Entity_Reference (N : Node_Id);
82 -- Common processing for expansion of identifiers and expanded names
83 -- Dispatches to specific expansion procedures.
85 procedure Expand_Entry_Index_Parameter (N : Node_Id);
86 -- A reference to the identifier in the entry index specification of an
87 -- entry body is modified to a reference to a constant definition equal to
88 -- the index of the entry family member being called. This constant is
89 -- calculated as part of the elaboration of the expanded code for the body,
90 -- and is calculated from the object-wide entry index returned by Next_
93 procedure Expand_Entry_Parameter (N : Node_Id);
94 -- A reference to an entry parameter is modified to be a reference to the
95 -- corresponding component of the entry parameter record that is passed by
96 -- the runtime to the accept body procedure.
98 procedure Expand_Formal (N : Node_Id);
99 -- A reference to a formal parameter of a protected subprogram is expanded
100 -- into the corresponding formal of the unprotected procedure used to
101 -- represent the operation within the protected object. In other cases
102 -- Expand_Formal is a no-op.
104 procedure Expand_Protected_Component (N : Node_Id);
105 -- A reference to a private component of a protected type is expanded into
106 -- a reference to the corresponding prival in the current protected entry
109 procedure Expand_Renaming (N : Node_Id);
110 -- For renamings, just replace the identifier by the corresponding
111 -- named expression. Note that this has been evaluated (see routine
112 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
113 -- the correct renaming semantics.
115 --------------------------
116 -- Expand_Current_Value --
117 --------------------------
119 procedure Expand_Current_Value (N : Node_Id) is
120 Loc : constant Source_Ptr := Sloc (N);
121 E : constant Entity_Id := Entity (N);
122 CV : constant Node_Id := Current_Value (E);
123 T : constant Entity_Id := Etype (N);
127 -- Start of processing for Expand_Current_Value
132 -- No replacement if value raises constraint error
134 and then Nkind (CV) /= N_Raise_Constraint_Error
136 -- Do this only for discrete types
138 and then Is_Discrete_Type (T)
140 -- Do not replace biased types, since it is problematic to
141 -- consistently generate a sensible constant value in this case.
143 and then not Has_Biased_Representation (T)
145 -- Do not replace lvalues
147 and then not May_Be_Lvalue (N)
149 -- Check that entity is suitable for replacement
151 and then OK_To_Do_Constant_Replacement (E)
153 -- Do not replace occurrences in pragmas (where names typically
154 -- appear not as values, but as simply names. If there are cases
155 -- where values are required, it is only a very minor efficiency
156 -- issue that they do not get replaced when they could be).
158 and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
160 -- Do not replace the prefixes of attribute references, since this
161 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
162 -- Name_Asm_Output, don't do replacement anywhere, since we can have
163 -- lvalue references in the arguments.
165 and then not (Nkind (Parent (N)) = N_Attribute_Reference
167 (Attribute_Name (Parent (N)) = Name_Asm_Input
169 Attribute_Name (Parent (N)) = Name_Asm_Output
171 Prefix (Parent (N)) = N))
174 -- Case of Current_Value is a compile time known value
176 if Nkind (CV) in N_Subexpr then
179 -- Case of Current_Value is a conditional expression reference
182 Get_Current_Value_Condition (N, Op, Val);
184 if Op /= N_Op_Eq then
189 -- If constant value is an occurrence of an enumeration literal,
190 -- then we just make another occurrence of the same literal.
192 if Is_Entity_Name (Val)
193 and then Ekind (Entity (Val)) = E_Enumeration_Literal
196 Unchecked_Convert_To (T,
197 New_Occurrence_Of (Entity (Val), Loc)));
199 -- If constant is of an integer type, just make an appropriately
200 -- integer literal, which will get the proper type.
202 elsif Is_Integer_Type (T) then
204 Make_Integer_Literal (Loc,
205 Intval => Expr_Rep_Value (Val)));
207 -- Otherwise do unchecked conversion of value to right type
211 Unchecked_Convert_To (T,
212 Make_Integer_Literal (Loc,
213 Intval => Expr_Rep_Value (Val))));
216 Analyze_And_Resolve (N, T);
217 Set_Is_Static_Expression (N, False);
219 end Expand_Current_Value;
221 -------------------------
222 -- Expand_Discriminant --
223 -------------------------
225 procedure Expand_Discriminant (N : Node_Id) is
226 Scop : constant Entity_Id := Scope (Entity (N));
228 Parent_P : Node_Id := Parent (P);
229 In_Entry : Boolean := False;
232 -- The Incomplete_Or_Private_Kind happens while resolving the
233 -- discriminant constraint involved in a derived full type,
236 -- type D is private;
237 -- type D(C : ...) is new T(C);
239 if Ekind (Scop) = E_Record_Type
240 or Ekind (Scop) in Incomplete_Or_Private_Kind
242 -- Find the origin by walking up the tree till the component
245 while Present (Parent_P)
246 and then Nkind (Parent_P) /= N_Component_Declaration
249 Parent_P := Parent (P);
252 -- If the discriminant reference was part of the default expression
253 -- it has to be "discriminalized"
255 if Present (Parent_P) and then P = Expression (Parent_P) then
256 Set_Entity (N, Discriminal (Entity (N)));
259 elsif Is_Concurrent_Type (Scop) then
260 while Present (Parent_P)
261 and then Nkind (Parent_P) /= N_Subprogram_Body
265 if Nkind (P) = N_Entry_Declaration then
269 Parent_P := Parent (Parent_P);
272 -- If the discriminant occurs within the default expression for a
273 -- formal of an entry or protected operation, replace it with a
274 -- reference to the discriminant of the formal of the enclosing
277 if Present (Parent_P)
278 and then Present (Corresponding_Spec (Parent_P))
281 Loc : constant Source_Ptr := Sloc (N);
282 D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
283 Formal : constant Entity_Id := First_Formal (D_Fun);
288 -- Verify that we are within the body of an entry or protected
289 -- operation. Its first formal parameter is the synchronized
293 and then Etype (Formal) = Scope (Entity (N))
295 Disc := CR_Discriminant (Entity (N));
298 Make_Selected_Component (Loc,
299 Prefix => New_Occurrence_Of (Formal, Loc),
300 Selector_Name => New_Occurrence_Of (Disc, Loc));
302 Set_Etype (New_N, Etype (N));
306 Set_Entity (N, Discriminal (Entity (N)));
310 elsif Nkind (Parent (N)) = N_Range
313 Set_Entity (N, CR_Discriminant (Entity (N)));
315 -- Finally, if the entity is the discriminant of the original
316 -- type declaration, and we are within the initialization
317 -- procedure for a task, the designated entity is the
318 -- discriminal of the task body. This can happen when the
319 -- argument of pragma Task_Name mentions a discriminant,
320 -- because the pragma is analyzed in the task declaration
321 -- but is expanded in the call to Create_Task in the init_proc.
323 elsif Within_Init_Proc then
324 Set_Entity (N, Discriminal (CR_Discriminant (Entity (N))));
326 Set_Entity (N, Discriminal (Entity (N)));
330 Set_Entity (N, Discriminal (Entity (N)));
332 end Expand_Discriminant;
334 -----------------------------
335 -- Expand_Entity_Reference --
336 -----------------------------
338 procedure Expand_Entity_Reference (N : Node_Id) is
339 E : constant Entity_Id := Entity (N);
342 -- Defend against errors
344 if No (E) and then Total_Errors_Detected /= 0 then
348 if Ekind (E) = E_Discriminant then
349 Expand_Discriminant (N);
351 elsif Is_Entry_Formal (E) then
352 Expand_Entry_Parameter (N);
354 elsif Is_Protected_Component (E) then
355 if No_Run_Time_Mode then
359 Expand_Protected_Component (N);
361 elsif Ekind (E) = E_Entry_Index_Parameter then
362 Expand_Entry_Index_Parameter (N);
364 elsif Is_Formal (E) then
367 elsif Is_Renaming_Of_Object (E) then
370 elsif Ekind (E) = E_Variable
371 and then Is_Shared_Passive (E)
373 Expand_Shared_Passive_Variable (N);
376 -- Test code for implementing the pragma Reviewable requirement of
377 -- classifying reads of scalars as referencing potentially uninitialized
381 and then Is_Scalar_Type (Etype (N))
382 and then (Is_Assignable (E) or else Is_Constant_Object (E))
383 and then Comes_From_Source (N)
384 and then not Is_LHS (N)
385 and then not Is_Actual_Out_Parameter (N)
386 and then (Nkind (Parent (N)) /= N_Attribute_Reference
387 or else Attribute_Name (Parent (N)) /= Name_Valid)
389 Write_Location (Sloc (N));
390 Write_Str (": Read from scalar """);
391 Write_Name (Chars (N));
393 if Is_Known_Valid (E) then
394 Write_Str (", Is_Known_Valid");
399 -- Interpret possible Current_Value for variable case
402 and then Present (Current_Value (E))
404 Expand_Current_Value (N);
406 -- We do want to warn for the case of a boolean variable (not a
407 -- boolean constant) whose value is known at compile time.
409 if Is_Boolean_Type (Etype (N)) then
410 Warn_On_Known_Condition (N);
413 -- Don't mess with Current_Value for compile time known values. Not
414 -- only is it unnecessary, but we could disturb an indication of a
415 -- static value, which could cause semantic trouble.
417 elsif Compile_Time_Known_Value (N) then
420 -- Interpret possible Current_Value for constant case
422 elsif Is_Constant_Object (E)
423 and then Present (Current_Value (E))
425 Expand_Current_Value (N);
427 end Expand_Entity_Reference;
429 ----------------------------------
430 -- Expand_Entry_Index_Parameter --
431 ----------------------------------
433 procedure Expand_Entry_Index_Parameter (N : Node_Id) is
434 Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
436 Set_Entity (N, Index_Con);
437 Set_Etype (N, Etype (Index_Con));
438 end Expand_Entry_Index_Parameter;
440 ----------------------------
441 -- Expand_Entry_Parameter --
442 ----------------------------
444 procedure Expand_Entry_Parameter (N : Node_Id) is
445 Loc : constant Source_Ptr := Sloc (N);
446 Ent_Formal : constant Entity_Id := Entity (N);
447 Ent_Spec : constant Entity_Id := Scope (Ent_Formal);
448 Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec);
449 Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec);
450 Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
451 P_Comp_Ref : Entity_Id;
453 function In_Assignment_Context (N : Node_Id) return Boolean;
454 -- Check whether this is a context in which the entry formal may be
457 ---------------------------
458 -- In_Assignment_Context --
459 ---------------------------
461 function In_Assignment_Context (N : Node_Id) return Boolean is
463 -- Case of use in a call
465 -- ??? passing a formal as actual for a mode IN formal is
466 -- considered as an assignment?
468 if Nkind_In (Parent (N), N_Procedure_Call_Statement,
469 N_Entry_Call_Statement)
470 or else (Nkind (Parent (N)) = N_Assignment_Statement
471 and then N = Name (Parent (N)))
475 -- Case of a parameter association: climb up to enclosing call
477 elsif Nkind (Parent (N)) = N_Parameter_Association then
478 return In_Assignment_Context (Parent (N));
480 -- Case of a selected component, indexed component or slice prefix:
481 -- climb up the tree, unless the prefix is of an access type (in
482 -- which case there is an implicit dereference, and the formal itself
483 -- is not being assigned to).
485 elsif Nkind_In (Parent (N), N_Selected_Component,
488 and then N = Prefix (Parent (N))
489 and then not Is_Access_Type (Etype (N))
490 and then In_Assignment_Context (Parent (N))
497 end In_Assignment_Context;
499 -- Start of processing for Expand_Entry_Parameter
502 if Is_Task_Type (Scope (Ent_Spec))
503 and then Comes_From_Source (Ent_Formal)
505 -- Before replacing the formal with the local renaming that is used
506 -- in the accept block, note if this is an assignment context, and
507 -- note the modification to avoid spurious warnings, because the
508 -- original entity is not used further. If formal is unconstrained,
509 -- we also generate an extra parameter to hold the Constrained
510 -- attribute of the actual. No renaming is generated for this flag.
512 -- Calling Note_Possible_Modification in the expander is dubious,
513 -- because this generates a cross-reference entry, and should be
514 -- done during semantic processing so it is called in -gnatc mode???
516 if Ekind (Entity (N)) /= E_In_Parameter
517 and then In_Assignment_Context (N)
519 Note_Possible_Modification (N, Sure => True);
522 Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
526 -- What we need is a reference to the corresponding component of the
527 -- parameter record object. The Accept_Address field of the entry entity
528 -- references the address variable that contains the address of the
529 -- accept parameters record. We first have to do an unchecked conversion
530 -- to turn this into a pointer to the parameter record and then we
531 -- select the required parameter field.
534 Make_Selected_Component (Loc,
536 Make_Explicit_Dereference (Loc,
537 Unchecked_Convert_To (Parm_Type,
538 New_Reference_To (Addr_Ent, Loc))),
540 New_Reference_To (Entry_Component (Ent_Formal), Loc));
542 -- For all types of parameters, the constructed parameter record object
543 -- contains a pointer to the parameter. Thus we must dereference them to
544 -- access them (this will often be redundant, since the dereference is
545 -- implicit, but no harm is done by making it explicit).
548 Make_Explicit_Dereference (Loc, P_Comp_Ref));
551 end Expand_Entry_Parameter;
557 procedure Expand_Formal (N : Node_Id) is
558 E : constant Entity_Id := Entity (N);
559 Scop : constant Entity_Id := Scope (E);
562 -- Check whether the subprogram of which this is a formal is
563 -- a protected operation. The initialization procedure for
564 -- the corresponding record type is not itself a protected operation.
566 if Is_Protected_Type (Scope (Scop))
567 and then not Is_Init_Proc (Scop)
568 and then Present (Protected_Formal (E))
570 Set_Entity (N, Protected_Formal (E));
574 ----------------------------
575 -- Expand_N_Expanded_Name --
576 ----------------------------
578 procedure Expand_N_Expanded_Name (N : Node_Id) is
580 Expand_Entity_Reference (N);
581 end Expand_N_Expanded_Name;
583 -------------------------
584 -- Expand_N_Identifier --
585 -------------------------
587 procedure Expand_N_Identifier (N : Node_Id) is
589 Expand_Entity_Reference (N);
590 end Expand_N_Identifier;
592 ---------------------------
593 -- Expand_N_Real_Literal --
594 ---------------------------
596 procedure Expand_N_Real_Literal (N : Node_Id) is
598 if Vax_Float (Etype (N)) then
599 Expand_Vax_Real_Literal (N);
601 end Expand_N_Real_Literal;
603 --------------------------------
604 -- Expand_Protected_Component --
605 --------------------------------
607 procedure Expand_Protected_Component (N : Node_Id) is
609 function Inside_Eliminated_Body return Boolean;
610 -- Determine whether the current entity is inside a subprogram or an
611 -- entry which has been marked as eliminated.
613 ----------------------------
614 -- Inside_Eliminated_Body --
615 ----------------------------
617 function Inside_Eliminated_Body return Boolean is
618 S : Entity_Id := Current_Scope;
621 while Present (S) loop
622 if (Ekind (S) = E_Entry
623 or else Ekind (S) = E_Entry_Family
624 or else Ekind (S) = E_Function
625 or else Ekind (S) = E_Procedure)
626 and then Is_Eliminated (S)
635 end Inside_Eliminated_Body;
637 -- Start of processing for Expand_Protected_Component
640 -- Eliminated bodies are not expanded and thus do not need privals
642 if not Inside_Eliminated_Body then
644 Priv : constant Entity_Id := Prival (Entity (N));
646 Set_Entity (N, Priv);
647 Set_Etype (N, Etype (Priv));
650 end Expand_Protected_Component;
652 ---------------------
653 -- Expand_Renaming --
654 ---------------------
656 procedure Expand_Renaming (N : Node_Id) is
657 E : constant Entity_Id := Entity (N);
658 T : constant Entity_Id := Etype (N);
661 Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
663 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
664 -- at the top level. This is needed in the packed case since we
665 -- specifically avoided expanding packed array references when the
666 -- renaming declaration was analyzed.
668 Reset_Analyzed_Flags (N);
669 Analyze_And_Resolve (N, T);
676 -- This would be trivial, simply a test for an identifier that was a
677 -- reference to a formal, if it were not for the fact that a previous call
678 -- to Expand_Entry_Parameter will have modified the reference to the
679 -- identifier. A formal of a protected entity is rewritten as
681 -- typ!(recobj).rec.all'Constrained
683 -- where rec is a selector whose Entry_Formal link points to the formal
684 -- For a formal of a task entity, the formal is rewritten as a local
687 -- In addition, a formal that is marked volatile because it is aliased
688 -- through an address clause is rewritten as dereference as well.
690 function Param_Entity (N : Node_Id) return Entity_Id is
691 Renamed_Obj : Node_Id;
694 -- Simple reference case
696 if Nkind_In (N, N_Identifier, N_Expanded_Name) then
697 if Is_Formal (Entity (N)) then
700 -- Handle renamings of formal parameters and formals of tasks that
701 -- are rewritten as renamings.
703 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then
704 Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N)));
706 if Is_Entity_Name (Renamed_Obj)
707 and then Is_Formal (Entity (Renamed_Obj))
709 return Entity (Renamed_Obj);
712 Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
719 if Nkind (N) = N_Explicit_Dereference then
721 P : constant Node_Id := Prefix (N);
725 if Nkind (P) = N_Selected_Component then
726 S := Selector_Name (P);
728 if Present (Entry_Formal (Entity (S))) then
729 return Entry_Formal (Entity (S));
732 elsif Nkind (Original_Node (N)) = N_Identifier then
733 return Param_Entity (Original_Node (N));