1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
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 Nmake; use Nmake;
38 with Sem_Attr; use Sem_Attr;
39 with Sem_Eval; use Sem_Eval;
40 with Sem_Res; use Sem_Res;
41 with Sem_Util; use Sem_Util;
42 with Sem_Warn; use Sem_Warn;
43 with Sinfo; use Sinfo;
44 with Tbuild; use Tbuild;
45 with Uintp; use Uintp;
47 package body Exp_Ch2 is
49 -----------------------
50 -- Local Subprograms --
51 -----------------------
53 procedure Expand_Current_Value (N : Node_Id);
54 -- N is a node for a variable whose Current_Value field is set. If N is
55 -- node is for a discrete type, replaces node with a copy of the referenced
56 -- value. This provides a limited form of value propagation for variables
57 -- which are initialized or assigned not been further modified at the time
58 -- of reference. The call has no effect if the Current_Value refers to a
59 -- conditional with condition other than equality.
61 procedure Expand_Discriminant (N : Node_Id);
62 -- An occurrence of a discriminant within a discriminated type is replaced
63 -- with the corresponding discriminal, that is to say the formal parameter
64 -- of the initialization procedure for the type that is associated with
65 -- that particular discriminant. This replacement is not performed for
66 -- discriminants of records that appear in constraints of component of the
67 -- record, because Gigi uses the discriminant name to retrieve its value.
68 -- In the other hand, it has to be performed for default expressions of
69 -- components because they are used in the record init procedure. See Einfo
70 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
71 -- discriminants of tasks and protected types, the transformation is more
72 -- complex when it occurs within a default expression for an entry or
73 -- protected operation. The corresponding default_expression_function has
74 -- an additional parameter which is the target of an entry call, and the
75 -- discriminant of the task must be replaced with a reference to the
76 -- discriminant of that formal parameter.
78 procedure Expand_Entity_Reference (N : Node_Id);
79 -- Common processing for expansion of identifiers and expanded names
80 -- Dispatches to specific expansion procedures.
82 procedure Expand_Entry_Index_Parameter (N : Node_Id);
83 -- A reference to the identifier in the entry index specification of
84 -- protected entry body is modified to a reference to a constant definition
85 -- equal to the index of the entry family member being called. This
86 -- constant is calculated as part of the elaboration of the expanded code
87 -- for the body, and is calculated from the object-wide entry index
88 -- returned by Next_Entry_Call.
90 procedure Expand_Entry_Parameter (N : Node_Id);
91 -- A reference to an entry parameter is modified to be a reference to the
92 -- corresponding component of the entry parameter record that is passed by
93 -- the runtime to the accept body procedure
95 procedure Expand_Formal (N : Node_Id);
96 -- A reference to a formal parameter of a protected subprogram is expanded
97 -- into the corresponding formal of the unprotected procedure used to
98 -- represent the operation within the protected object. In other cases
99 -- Expand_Formal is a noop.
101 procedure Expand_Protected_Private (N : Node_Id);
102 -- A reference to a private component of a protected type is expanded to a
103 -- component selected from the record used to implement the protected
104 -- object. Such a record is passed to all operations on a protected object
105 -- in a parameter named _object. This object is a constant in the body of a
106 -- function, and a variable within a procedure or entry body.
108 procedure Expand_Renaming (N : Node_Id);
109 -- For renamings, just replace the identifier by the corresponding
110 -- named expression. Note that this has been evaluated (see routine
111 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
112 -- the correct renaming semantics.
114 --------------------------
115 -- Expand_Current_Value --
116 --------------------------
118 procedure Expand_Current_Value (N : Node_Id) is
119 Loc : constant Source_Ptr := Sloc (N);
120 E : constant Entity_Id := Entity (N);
121 CV : constant Node_Id := Current_Value (E);
122 T : constant Entity_Id := Etype (N);
126 -- Start of processing for Expand_Current_Value
131 -- No replacement if value raises constraint error
133 and then Nkind (CV) /= N_Raise_Constraint_Error
135 -- Do this only for discrete types
137 and then Is_Discrete_Type (T)
139 -- Do not replace biased types, since it is problematic to
140 -- consistently generate a sensible constant value in this case.
142 and then not Has_Biased_Representation (T)
144 -- Do not replace lvalues
146 and then not May_Be_Lvalue (N)
148 -- Check that entity is suitable for replacement
150 and then OK_To_Do_Constant_Replacement (E)
152 -- Do not replace occurrences in pragmas (where names typically
153 -- appear not as values, but as simply names. If there are cases
154 -- where values are required, it is only a very minor efficiency
155 -- issue that they do not get replaced when they could be).
157 and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
159 -- Same for attribute references that require a simple name prefix
161 and then not (Nkind (Parent (N)) = N_Attribute_Reference
162 and then Requires_Simple_Name_Prefix (
163 Attribute_Name (Parent (N))))
166 -- Case of Current_Value is a compile time known value
168 if Nkind (CV) in N_Subexpr then
171 -- Case of Current_Value is a conditional expression reference
174 Get_Current_Value_Condition (N, Op, Val);
176 if Op /= N_Op_Eq then
181 -- If constant value is an occurrence of an enumeration literal,
182 -- then we just make another occurence of the same literal.
184 if Is_Entity_Name (Val)
185 and then Ekind (Entity (Val)) = E_Enumeration_Literal
188 Unchecked_Convert_To (T,
189 New_Occurrence_Of (Entity (Val), Loc)));
191 -- Otherwise get the value, and convert to appropriate type
195 Unchecked_Convert_To (T,
196 Make_Integer_Literal (Loc,
197 Intval => Expr_Rep_Value (Val))));
200 Analyze_And_Resolve (N, T);
201 Set_Is_Static_Expression (N, False);
203 end Expand_Current_Value;
205 -------------------------
206 -- Expand_Discriminant --
207 -------------------------
209 procedure Expand_Discriminant (N : Node_Id) is
210 Scop : constant Entity_Id := Scope (Entity (N));
212 Parent_P : Node_Id := Parent (P);
213 In_Entry : Boolean := False;
216 -- The Incomplete_Or_Private_Kind happens while resolving the
217 -- discriminant constraint involved in a derived full type,
220 -- type D is private;
221 -- type D(C : ...) is new T(C);
223 if Ekind (Scop) = E_Record_Type
224 or Ekind (Scop) in Incomplete_Or_Private_Kind
226 -- Find the origin by walking up the tree till the component
229 while Present (Parent_P)
230 and then Nkind (Parent_P) /= N_Component_Declaration
233 Parent_P := Parent (P);
236 -- If the discriminant reference was part of the default expression
237 -- it has to be "discriminalized"
239 if Present (Parent_P) and then P = Expression (Parent_P) then
240 Set_Entity (N, Discriminal (Entity (N)));
243 elsif Is_Concurrent_Type (Scop) then
244 while Present (Parent_P)
245 and then Nkind (Parent_P) /= N_Subprogram_Body
249 if Nkind (P) = N_Entry_Declaration then
253 Parent_P := Parent (Parent_P);
256 -- If the discriminant occurs within the default expression for a
257 -- formal of an entry or protected operation, create a default
258 -- function for it, and replace the discriminant with a reference to
259 -- the discriminant of the formal of the default function. The
260 -- discriminant entity is the one defined in the corresponding
263 if Present (Parent_P)
264 and then Present (Corresponding_Spec (Parent_P))
267 Loc : constant Source_Ptr := Sloc (N);
268 D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
269 Formal : constant Entity_Id := First_Formal (D_Fun);
274 -- Verify that we are within a default function: the type of
275 -- its formal parameter is the same task or protected type.
278 and then Etype (Formal) = Scope (Entity (N))
280 Disc := CR_Discriminant (Entity (N));
283 Make_Selected_Component (Loc,
284 Prefix => New_Occurrence_Of (Formal, Loc),
285 Selector_Name => New_Occurrence_Of (Disc, Loc));
287 Set_Etype (New_N, Etype (N));
291 Set_Entity (N, Discriminal (Entity (N)));
295 elsif Nkind (Parent (N)) = N_Range
298 Set_Entity (N, CR_Discriminant (Entity (N)));
300 Set_Entity (N, Discriminal (Entity (N)));
304 Set_Entity (N, Discriminal (Entity (N)));
306 end Expand_Discriminant;
308 -----------------------------
309 -- Expand_Entity_Reference --
310 -----------------------------
312 procedure Expand_Entity_Reference (N : Node_Id) is
313 E : constant Entity_Id := Entity (N);
316 -- Defend against errors
318 if No (E) and then Total_Errors_Detected /= 0 then
322 if Ekind (E) = E_Discriminant then
323 Expand_Discriminant (N);
325 elsif Is_Entry_Formal (E) then
326 Expand_Entry_Parameter (N);
328 elsif Ekind (E) = E_Component
329 and then Is_Protected_Private (E)
331 -- Protect against junk use of tasking in no run time mode
333 if No_Run_Time_Mode then
337 Expand_Protected_Private (N);
339 elsif Ekind (E) = E_Entry_Index_Parameter then
340 Expand_Entry_Index_Parameter (N);
342 elsif Is_Formal (E) then
345 elsif Is_Renaming_Of_Object (E) then
348 elsif Ekind (E) = E_Variable
349 and then Is_Shared_Passive (E)
351 Expand_Shared_Passive_Variable (N);
354 -- Interpret possible Current_Value for variable case
356 if (Ekind (E) = E_Variable
358 Ekind (E) = E_In_Out_Parameter
360 Ekind (E) = E_Out_Parameter)
361 and then Present (Current_Value (E))
363 Expand_Current_Value (N);
365 -- We do want to warn for the case of a boolean variable (not a
366 -- boolean constant) whose value is known at compile time.
368 if Is_Boolean_Type (Etype (N)) then
369 Warn_On_Known_Condition (N);
372 -- Don't mess with Current_Value for compile time known values. Not
373 -- only is it unnecessary, but we could disturb an indication of a
374 -- static value, which could cause semantic trouble.
376 elsif Compile_Time_Known_Value (N) then
379 -- Interpret possible Current_Value for constant case
381 elsif (Ekind (E) = E_Constant
383 Ekind (E) = E_In_Parameter
385 Ekind (E) = E_Loop_Parameter)
386 and then Present (Current_Value (E))
388 Expand_Current_Value (N);
390 end Expand_Entity_Reference;
392 ----------------------------------
393 -- Expand_Entry_Index_Parameter --
394 ----------------------------------
396 procedure Expand_Entry_Index_Parameter (N : Node_Id) is
398 Set_Entity (N, Entry_Index_Constant (Entity (N)));
399 end Expand_Entry_Index_Parameter;
401 ----------------------------
402 -- Expand_Entry_Parameter --
403 ----------------------------
405 procedure Expand_Entry_Parameter (N : Node_Id) is
406 Loc : constant Source_Ptr := Sloc (N);
407 Ent_Formal : constant Entity_Id := Entity (N);
408 Ent_Spec : constant Entity_Id := Scope (Ent_Formal);
409 Parm_Type : constant Entity_Id := Entry_Parameters_Type (Ent_Spec);
410 Acc_Stack : constant Elist_Id := Accept_Address (Ent_Spec);
411 Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
412 P_Comp_Ref : Entity_Id;
414 function In_Assignment_Context (N : Node_Id) return Boolean;
415 -- Check whether this is a context in which the entry formal may be
418 ---------------------------
419 -- In_Assignment_Context --
420 ---------------------------
422 function In_Assignment_Context (N : Node_Id) return Boolean is
424 if Nkind (Parent (N)) = N_Procedure_Call_Statement
425 or else Nkind (Parent (N)) = N_Entry_Call_Statement
427 (Nkind (Parent (N)) = N_Assignment_Statement
428 and then N = Name (Parent (N)))
432 elsif Nkind (Parent (N)) = N_Parameter_Association then
433 return In_Assignment_Context (Parent (N));
435 elsif (Nkind (Parent (N)) = N_Selected_Component
436 or else Nkind (Parent (N)) = N_Indexed_Component
437 or else Nkind (Parent (N)) = N_Slice)
438 and then In_Assignment_Context (Parent (N))
444 end In_Assignment_Context;
446 -- Start of processing for Expand_Entry_Parameter
449 if Is_Task_Type (Scope (Ent_Spec))
450 and then Comes_From_Source (Ent_Formal)
452 -- Before replacing the formal with the local renaming that is used
453 -- in the accept block, note if this is an assignment context, and
454 -- note the modification to avoid spurious warnings, because the
455 -- original entity is not used further. If formal is unconstrained,
456 -- we also generate an extra parameter to hold the Constrained
457 -- attribute of the actual. No renaming is generated for this flag.
459 if Ekind (Entity (N)) /= E_In_Parameter
460 and then In_Assignment_Context (N)
462 Note_Possible_Modification (N);
465 Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
469 -- What we need is a reference to the corresponding component of the
470 -- parameter record object. The Accept_Address field of the entry entity
471 -- references the address variable that contains the address of the
472 -- accept parameters record. We first have to do an unchecked conversion
473 -- to turn this into a pointer to the parameter record and then we
474 -- select the required parameter field.
477 Make_Selected_Component (Loc,
479 Make_Explicit_Dereference (Loc,
480 Unchecked_Convert_To (Parm_Type,
481 New_Reference_To (Addr_Ent, Loc))),
483 New_Reference_To (Entry_Component (Ent_Formal), Loc));
485 -- For all types of parameters, the constructed parameter record object
486 -- contains a pointer to the parameter. Thus we must dereference them to
487 -- access them (this will often be redundant, since the needed deference
488 -- is implicit, but no harm is done by making it explicit).
491 Make_Explicit_Dereference (Loc, P_Comp_Ref));
494 end Expand_Entry_Parameter;
500 procedure Expand_Formal (N : Node_Id) is
501 E : constant Entity_Id := Entity (N);
502 Scop : constant Entity_Id := Scope (E);
505 -- Check whether the subprogram of which this is a formal is
506 -- a protected operation. The initialization procedure for
507 -- the corresponding record type is not itself a protected operation.
509 if Is_Protected_Type (Scope (Scop))
510 and then not Is_Init_Proc (Scop)
511 and then Present (Protected_Formal (E))
513 Set_Entity (N, Protected_Formal (E));
517 ----------------------------
518 -- Expand_N_Expanded_Name --
519 ----------------------------
521 procedure Expand_N_Expanded_Name (N : Node_Id) is
523 Expand_Entity_Reference (N);
524 end Expand_N_Expanded_Name;
526 -------------------------
527 -- Expand_N_Identifier --
528 -------------------------
530 procedure Expand_N_Identifier (N : Node_Id) is
532 Expand_Entity_Reference (N);
533 end Expand_N_Identifier;
535 ---------------------------
536 -- Expand_N_Real_Literal --
537 ---------------------------
539 procedure Expand_N_Real_Literal (N : Node_Id) is
541 if Vax_Float (Etype (N)) then
542 Expand_Vax_Real_Literal (N);
544 end Expand_N_Real_Literal;
546 ------------------------------
547 -- Expand_Protected_Private --
548 ------------------------------
550 procedure Expand_Protected_Private (N : Node_Id) is
551 Loc : constant Source_Ptr := Sloc (N);
552 E : constant Entity_Id := Entity (N);
553 Op : constant Node_Id := Protected_Operation (E);
560 if Nkind (Op) /= N_Subprogram_Body
561 or else Nkind (Specification (Op)) /= N_Function_Specification
563 Set_Ekind (Prival (E), E_Variable);
565 Set_Ekind (Prival (E), E_Constant);
568 -- If the private component appears in an assignment (either lhs or
569 -- rhs) and is a one-dimensional array constrained by a discriminant,
570 -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
571 -- is directly visible. This solves delicate visibility problems.
573 if Comes_From_Source (N)
574 and then Is_Array_Type (Etype (E))
575 and then Number_Dimensions (Etype (E)) = 1
576 and then not Within_Init_Proc
578 Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
579 Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
581 if Nkind (Parent (N)) = N_Assignment_Statement
582 and then ((Is_Entity_Name (Lo)
583 and then Ekind (Entity (Lo)) = E_In_Parameter)
584 or else (Is_Entity_Name (Hi)
586 Ekind (Entity (Hi)) = E_In_Parameter))
588 D_Range := New_Node (N_Range, Loc);
590 if Is_Entity_Name (Lo)
591 and then Ekind (Entity (Lo)) = E_In_Parameter
593 Set_Low_Bound (D_Range,
594 Make_Identifier (Loc, Chars (Entity (Lo))));
596 Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
599 if Is_Entity_Name (Hi)
600 and then Ekind (Entity (Hi)) = E_In_Parameter
602 Set_High_Bound (D_Range,
603 Make_Identifier (Loc, Chars (Entity (Hi))));
605 Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
610 Prefix => New_Occurrence_Of (E, Loc),
611 Discrete_Range => D_Range));
613 Analyze_And_Resolve (N, Etype (E));
618 -- The type of the reference is the type of the prival, which may differ
619 -- from that of the original component if it is an itype.
621 Set_Entity (N, Prival (E));
622 Set_Etype (N, Etype (Prival (E)));
623 Scop := Current_Scope;
625 -- Find entity for protected operation, which must be on scope stack
627 while not Is_Protected_Type (Scope (Scop)) loop
628 Scop := Scope (Scop);
631 Append_Elmt (N, Privals_Chain (Scop));
632 end Expand_Protected_Private;
634 ---------------------
635 -- Expand_Renaming --
636 ---------------------
638 procedure Expand_Renaming (N : Node_Id) is
639 E : constant Entity_Id := Entity (N);
640 T : constant Entity_Id := Etype (N);
643 Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
645 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
646 -- at the top level. This is needed in the packed case since we
647 -- specifically avoided expanding packed array references when the
648 -- renaming declaration was analyzed.
650 Reset_Analyzed_Flags (N);
651 Analyze_And_Resolve (N, T);
658 -- This would be trivial, simply a test for an identifier that was a
659 -- reference to a formal, if it were not for the fact that a previous call
660 -- to Expand_Entry_Parameter will have modified the reference to the
661 -- identifier. A formal of a protected entity is rewritten as
663 -- typ!(recobj).rec.all'Constrained
665 -- where rec is a selector whose Entry_Formal link points to the formal
666 -- For a formal of a task entity, the formal is rewritten as a local
669 -- In addition, a formal that is marked volatile because it is aliased
670 -- through an address clause is rewritten as dereference as well.
672 function Param_Entity (N : Node_Id) return Entity_Id is
674 -- Simple reference case
676 if Nkind (N) = N_Identifier or else Nkind (N) = N_Expanded_Name then
677 if Is_Formal (Entity (N)) then
680 elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
681 and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
687 if Nkind (N) = N_Explicit_Dereference then
689 P : constant Node_Id := Prefix (N);
693 if Nkind (P) = N_Selected_Component then
694 S := Selector_Name (P);
696 if Present (Entry_Formal (Entity (S))) then
697 return Entry_Formal (Entity (S));
700 elsif Nkind (Original_Node (N)) = N_Identifier then
701 return Param_Entity (Original_Node (N));