1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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 Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Exp_Smem
; use Exp_Smem
;
33 with Exp_Tss
; use Exp_Tss
;
34 with Exp_Util
; use Exp_Util
;
35 with Exp_VFpt
; use Exp_VFpt
;
36 with Namet
; use Namet
;
37 with Nmake
; use Nmake
;
39 with Output
; use Output
;
41 with Sem_Eval
; use Sem_Eval
;
42 with Sem_Res
; use Sem_Res
;
43 with Sem_Util
; use Sem_Util
;
44 with Sem_Warn
; use Sem_Warn
;
45 with Sinfo
; use Sinfo
;
46 with Sinput
; use Sinput
;
47 with Snames
; use Snames
;
48 with Tbuild
; use Tbuild
;
49 with Uintp
; use Uintp
;
51 package body Exp_Ch2
is
53 -----------------------
54 -- Local Subprograms --
55 -----------------------
57 procedure Expand_Current_Value
(N
: Node_Id
);
58 -- N is a node for a variable whose Current_Value field is set. If N is
59 -- node is for a discrete type, replaces node with a copy of the referenced
60 -- value. This provides a limited form of value propagation for variables
61 -- which are initialized or assigned not been further modified at the time
62 -- of reference. The call has no effect if the Current_Value refers to a
63 -- conditional with condition other than equality.
65 procedure Expand_Discriminant
(N
: Node_Id
);
66 -- An occurrence of a discriminant within a discriminated type is replaced
67 -- with the corresponding discriminal, that is to say the formal parameter
68 -- of the initialization procedure for the type that is associated with
69 -- that particular discriminant. This replacement is not performed for
70 -- discriminants of records that appear in constraints of component of the
71 -- record, because Gigi uses the discriminant name to retrieve its value.
72 -- In the other hand, it has to be performed for default expressions of
73 -- components because they are used in the record init procedure. See Einfo
74 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
75 -- discriminants of tasks and protected types, the transformation is more
76 -- complex when it occurs within a default expression for an entry or
77 -- protected operation. The corresponding default_expression_function has
78 -- an additional parameter which is the target of an entry call, and the
79 -- discriminant of the task must be replaced with a reference to the
80 -- discriminant of that formal parameter.
82 procedure Expand_Entity_Reference
(N
: Node_Id
);
83 -- Common processing for expansion of identifiers and expanded names
84 -- Dispatches to specific expansion procedures.
86 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
);
87 -- A reference to the identifier in the entry index specification of an
88 -- entry body is modified to a reference to a constant definition equal to
89 -- the index of the entry family member being called. This constant is
90 -- calculated as part of the elaboration of the expanded code for the body,
91 -- and is calculated from the object-wide entry index returned by Next_
94 procedure Expand_Entry_Parameter
(N
: Node_Id
);
95 -- A reference to an entry parameter is modified to be a reference to the
96 -- corresponding component of the entry parameter record that is passed by
97 -- the runtime to the accept body procedure.
99 procedure Expand_Formal
(N
: Node_Id
);
100 -- A reference to a formal parameter of a protected subprogram is expanded
101 -- into the corresponding formal of the unprotected procedure used to
102 -- represent the operation within the protected object. In other cases
103 -- Expand_Formal is a no-op.
105 procedure Expand_Protected_Component
(N
: Node_Id
);
106 -- A reference to a private component of a protected type is expanded into
107 -- a reference to the corresponding prival in the current protected entry
110 procedure Expand_Renaming
(N
: Node_Id
);
111 -- For renamings, just replace the identifier by the corresponding
112 -- named expression. Note that this has been evaluated (see routine
113 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
114 -- the correct renaming semantics.
116 --------------------------
117 -- Expand_Current_Value --
118 --------------------------
120 procedure Expand_Current_Value
(N
: Node_Id
) is
121 Loc
: constant Source_Ptr
:= Sloc
(N
);
122 E
: constant Entity_Id
:= Entity
(N
);
123 CV
: constant Node_Id
:= Current_Value
(E
);
124 T
: constant Entity_Id
:= Etype
(N
);
128 -- Start of processing for Expand_Current_Value
133 -- No replacement if value raises constraint error
135 and then Nkind
(CV
) /= N_Raise_Constraint_Error
137 -- Do this only for discrete types
139 and then Is_Discrete_Type
(T
)
141 -- Do not replace biased types, since it is problematic to
142 -- consistently generate a sensible constant value in this case.
144 and then not Has_Biased_Representation
(T
)
146 -- Do not replace lvalues
148 and then not May_Be_Lvalue
(N
)
150 -- Check that entity is suitable for replacement
152 and then OK_To_Do_Constant_Replacement
(E
)
154 -- Do not replace occurrences in pragmas (where names typically
155 -- appear not as values, but as simply names. If there are cases
156 -- where values are required, it is only a very minor efficiency
157 -- issue that they do not get replaced when they could be).
159 and then Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
161 -- Do not replace the prefixes of attribute references, since this
162 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
163 -- Name_Asm_Output, don't do replacement anywhere, since we can have
164 -- lvalue references in the arguments.
166 and then not (Nkind
(Parent
(N
)) = N_Attribute_Reference
168 (Attribute_Name
(Parent
(N
)) = Name_Asm_Input
170 Attribute_Name
(Parent
(N
)) = Name_Asm_Output
172 Prefix
(Parent
(N
)) = N
))
175 -- Case of Current_Value is a compile time known value
177 if Nkind
(CV
) in N_Subexpr
then
180 -- Case of Current_Value is a conditional expression reference
183 Get_Current_Value_Condition
(N
, Op
, Val
);
185 if Op
/= N_Op_Eq
then
190 -- If constant value is an occurrence of an enumeration literal,
191 -- then we just make another occurrence of the same literal.
193 if Is_Entity_Name
(Val
)
194 and then Ekind
(Entity
(Val
)) = E_Enumeration_Literal
197 Unchecked_Convert_To
(T
,
198 New_Occurrence_Of
(Entity
(Val
), Loc
)));
200 -- If constant is of an integer type, just make an appropriately
201 -- integer literal, which will get the proper type.
203 elsif Is_Integer_Type
(T
) then
205 Make_Integer_Literal
(Loc
,
206 Intval
=> Expr_Rep_Value
(Val
)));
208 -- Otherwise do unchecked conversion of value to right type
212 Unchecked_Convert_To
(T
,
213 Make_Integer_Literal
(Loc
,
214 Intval
=> Expr_Rep_Value
(Val
))));
217 Analyze_And_Resolve
(N
, T
);
218 Set_Is_Static_Expression
(N
, False);
220 end Expand_Current_Value
;
222 -------------------------
223 -- Expand_Discriminant --
224 -------------------------
226 procedure Expand_Discriminant
(N
: Node_Id
) is
227 Scop
: constant Entity_Id
:= Scope
(Entity
(N
));
229 Parent_P
: Node_Id
:= Parent
(P
);
230 In_Entry
: Boolean := False;
233 -- The Incomplete_Or_Private_Kind happens while resolving the
234 -- discriminant constraint involved in a derived full type,
237 -- type D is private;
238 -- type D(C : ...) is new T(C);
240 if Ekind
(Scop
) = E_Record_Type
241 or Ekind
(Scop
) in Incomplete_Or_Private_Kind
243 -- Find the origin by walking up the tree till the component
246 while Present
(Parent_P
)
247 and then Nkind
(Parent_P
) /= N_Component_Declaration
250 Parent_P
:= Parent
(P
);
253 -- If the discriminant reference was part of the default expression
254 -- it has to be "discriminalized"
256 if Present
(Parent_P
) and then P
= Expression
(Parent_P
) then
257 Set_Entity
(N
, Discriminal
(Entity
(N
)));
260 elsif Is_Concurrent_Type
(Scop
) then
261 while Present
(Parent_P
)
262 and then Nkind
(Parent_P
) /= N_Subprogram_Body
266 if Nkind
(P
) = N_Entry_Declaration
then
270 Parent_P
:= Parent
(Parent_P
);
273 -- If the discriminant occurs within the default expression for a
274 -- formal of an entry or protected operation, replace it with a
275 -- reference to the discriminant of the formal of the enclosing
278 if Present
(Parent_P
)
279 and then Present
(Corresponding_Spec
(Parent_P
))
282 Loc
: constant Source_Ptr
:= Sloc
(N
);
283 D_Fun
: constant Entity_Id
:= Corresponding_Spec
(Parent_P
);
284 Formal
: constant Entity_Id
:= First_Formal
(D_Fun
);
289 -- Verify that we are within the body of an entry or protected
290 -- operation. Its first formal parameter is the synchronized
294 and then Etype
(Formal
) = Scope
(Entity
(N
))
296 Disc
:= CR_Discriminant
(Entity
(N
));
299 Make_Selected_Component
(Loc
,
300 Prefix
=> New_Occurrence_Of
(Formal
, Loc
),
301 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
303 Set_Etype
(New_N
, Etype
(N
));
307 Set_Entity
(N
, Discriminal
(Entity
(N
)));
311 elsif Nkind
(Parent
(N
)) = N_Range
314 Set_Entity
(N
, CR_Discriminant
(Entity
(N
)));
316 -- Finally, if the entity is the discriminant of the original
317 -- type declaration, and we are within the initialization
318 -- procedure for a task, the designated entity is the
319 -- discriminal of the task body. This can happen when the
320 -- argument of pragma Task_Name mentions a discriminant,
321 -- because the pragma is analyzed in the task declaration
322 -- but is expanded in the call to Create_Task in the init_proc.
324 elsif Within_Init_Proc
then
325 Set_Entity
(N
, Discriminal
(CR_Discriminant
(Entity
(N
))));
327 Set_Entity
(N
, Discriminal
(Entity
(N
)));
331 Set_Entity
(N
, Discriminal
(Entity
(N
)));
333 end Expand_Discriminant
;
335 -----------------------------
336 -- Expand_Entity_Reference --
337 -----------------------------
339 procedure Expand_Entity_Reference
(N
: Node_Id
) is
340 E
: constant Entity_Id
:= Entity
(N
);
343 -- Defend against errors
345 if No
(E
) and then Total_Errors_Detected
/= 0 then
349 if Ekind
(E
) = E_Discriminant
then
350 Expand_Discriminant
(N
);
352 elsif Is_Entry_Formal
(E
) then
353 Expand_Entry_Parameter
(N
);
355 elsif Is_Protected_Component
(E
) then
356 if No_Run_Time_Mode
then
359 Expand_Protected_Component
(N
);
362 elsif Ekind
(E
) = E_Entry_Index_Parameter
then
363 Expand_Entry_Index_Parameter
(N
);
365 elsif Is_Formal
(E
) then
368 elsif Is_Renaming_Of_Object
(E
) then
371 elsif Ekind
(E
) = E_Variable
372 and then Is_Shared_Passive
(E
)
374 Expand_Shared_Passive_Variable
(N
);
377 -- Test code for implementing the pragma Reviewable requirement of
378 -- classifying reads of scalars as referencing potentially uninitialized
382 and then Is_Scalar_Type
(Etype
(N
))
383 and then (Is_Assignable
(E
) or else Is_Constant_Object
(E
))
384 and then Comes_From_Source
(N
)
385 and then not Is_LHS
(N
)
386 and then not Is_Actual_Out_Parameter
(N
)
387 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
388 or else Attribute_Name
(Parent
(N
)) /= Name_Valid
)
390 Write_Location
(Sloc
(N
));
391 Write_Str
(": Read from scalar """);
392 Write_Name
(Chars
(N
));
395 if Is_Known_Valid
(E
) then
396 Write_Str
(", Is_Known_Valid");
402 -- Set Atomic_Sync_Required if necessary for atomic variable
404 if Nkind_In
(N
, N_Identifier
, N_Expanded_Name
)
405 and then Ekind
(E
) = E_Variable
406 and then (Is_Atomic
(E
) or else Is_Atomic
(Etype
(E
)))
412 -- If variable is atomic, but type is not, setting depends on
413 -- disable/enable state for the variable.
415 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
416 Set
:= not Atomic_Synchronization_Disabled
(E
);
418 -- If variable is not atomic, but its type is atomic, setting
419 -- depends on disable/enable state for the type.
421 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
422 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
424 -- Else both variable and type are atomic (see outer if), and we
425 -- disable if either variable or its type have sync disabled.
428 Set
:= (not Atomic_Synchronization_Disabled
(E
))
430 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
433 -- Set flag if required
436 Activate_Atomic_Synchronization
(N
);
441 -- Interpret possible Current_Value for variable case
444 and then Present
(Current_Value
(E
))
446 Expand_Current_Value
(N
);
448 -- We do want to warn for the case of a boolean variable (not a
449 -- boolean constant) whose value is known at compile time.
451 if Is_Boolean_Type
(Etype
(N
)) then
452 Warn_On_Known_Condition
(N
);
455 -- Don't mess with Current_Value for compile time known values. Not
456 -- only is it unnecessary, but we could disturb an indication of a
457 -- static value, which could cause semantic trouble.
459 elsif Compile_Time_Known_Value
(N
) then
462 -- Interpret possible Current_Value for constant case
464 elsif Is_Constant_Object
(E
)
465 and then Present
(Current_Value
(E
))
467 Expand_Current_Value
(N
);
469 end Expand_Entity_Reference
;
471 ----------------------------------
472 -- Expand_Entry_Index_Parameter --
473 ----------------------------------
475 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
) is
476 Index_Con
: constant Entity_Id
:= Entry_Index_Constant
(Entity
(N
));
478 Set_Entity
(N
, Index_Con
);
479 Set_Etype
(N
, Etype
(Index_Con
));
480 end Expand_Entry_Index_Parameter
;
482 ----------------------------
483 -- Expand_Entry_Parameter --
484 ----------------------------
486 procedure Expand_Entry_Parameter
(N
: Node_Id
) is
487 Loc
: constant Source_Ptr
:= Sloc
(N
);
488 Ent_Formal
: constant Entity_Id
:= Entity
(N
);
489 Ent_Spec
: constant Entity_Id
:= Scope
(Ent_Formal
);
490 Parm_Type
: constant Entity_Id
:= Entry_Parameters_Type
(Ent_Spec
);
491 Acc_Stack
: constant Elist_Id
:= Accept_Address
(Ent_Spec
);
492 Addr_Ent
: constant Entity_Id
:= Node
(Last_Elmt
(Acc_Stack
));
493 P_Comp_Ref
: Entity_Id
;
495 function In_Assignment_Context
(N
: Node_Id
) return Boolean;
496 -- Check whether this is a context in which the entry formal may be
499 ---------------------------
500 -- In_Assignment_Context --
501 ---------------------------
503 function In_Assignment_Context
(N
: Node_Id
) return Boolean is
505 -- Case of use in a call
507 -- ??? passing a formal as actual for a mode IN formal is
508 -- considered as an assignment?
510 if Nkind_In
(Parent
(N
), N_Procedure_Call_Statement
,
511 N_Entry_Call_Statement
)
512 or else (Nkind
(Parent
(N
)) = N_Assignment_Statement
513 and then N
= Name
(Parent
(N
)))
517 -- Case of a parameter association: climb up to enclosing call
519 elsif Nkind
(Parent
(N
)) = N_Parameter_Association
then
520 return In_Assignment_Context
(Parent
(N
));
522 -- Case of a selected component, indexed component or slice prefix:
523 -- climb up the tree, unless the prefix is of an access type (in
524 -- which case there is an implicit dereference, and the formal itself
525 -- is not being assigned to).
527 elsif Nkind_In
(Parent
(N
), N_Selected_Component
,
530 and then N
= Prefix
(Parent
(N
))
531 and then not Is_Access_Type
(Etype
(N
))
532 and then In_Assignment_Context
(Parent
(N
))
539 end In_Assignment_Context
;
541 -- Start of processing for Expand_Entry_Parameter
544 if Is_Task_Type
(Scope
(Ent_Spec
))
545 and then Comes_From_Source
(Ent_Formal
)
547 -- Before replacing the formal with the local renaming that is used
548 -- in the accept block, note if this is an assignment context, and
549 -- note the modification to avoid spurious warnings, because the
550 -- original entity is not used further. If formal is unconstrained,
551 -- we also generate an extra parameter to hold the Constrained
552 -- attribute of the actual. No renaming is generated for this flag.
554 -- Calling Note_Possible_Modification in the expander is dubious,
555 -- because this generates a cross-reference entry, and should be
556 -- done during semantic processing so it is called in -gnatc mode???
558 if Ekind
(Entity
(N
)) /= E_In_Parameter
559 and then In_Assignment_Context
(N
)
561 Note_Possible_Modification
(N
, Sure
=> True);
565 -- What we need is a reference to the corresponding component of the
566 -- parameter record object. The Accept_Address field of the entry entity
567 -- references the address variable that contains the address of the
568 -- accept parameters record. We first have to do an unchecked conversion
569 -- to turn this into a pointer to the parameter record and then we
570 -- select the required parameter field.
572 -- The same processing applies to protected entries, where the Accept_
573 -- Address is also the address of the Parameters record.
576 Make_Selected_Component
(Loc
,
578 Make_Explicit_Dereference
(Loc
,
579 Unchecked_Convert_To
(Parm_Type
,
580 New_Reference_To
(Addr_Ent
, Loc
))),
582 New_Reference_To
(Entry_Component
(Ent_Formal
), Loc
));
584 -- For all types of parameters, the constructed parameter record object
585 -- contains a pointer to the parameter. Thus we must dereference them to
586 -- access them (this will often be redundant, since the dereference is
587 -- implicit, but no harm is done by making it explicit).
590 Make_Explicit_Dereference
(Loc
, P_Comp_Ref
));
593 end Expand_Entry_Parameter
;
599 procedure Expand_Formal
(N
: Node_Id
) is
600 E
: constant Entity_Id
:= Entity
(N
);
601 Scop
: constant Entity_Id
:= Scope
(E
);
604 -- Check whether the subprogram of which this is a formal is
605 -- a protected operation. The initialization procedure for
606 -- the corresponding record type is not itself a protected operation.
608 if Is_Protected_Type
(Scope
(Scop
))
609 and then not Is_Init_Proc
(Scop
)
610 and then Present
(Protected_Formal
(E
))
612 Set_Entity
(N
, Protected_Formal
(E
));
616 ----------------------------
617 -- Expand_N_Expanded_Name --
618 ----------------------------
620 procedure Expand_N_Expanded_Name
(N
: Node_Id
) is
622 Expand_Entity_Reference
(N
);
623 end Expand_N_Expanded_Name
;
625 -------------------------
626 -- Expand_N_Identifier --
627 -------------------------
629 procedure Expand_N_Identifier
(N
: Node_Id
) is
631 Expand_Entity_Reference
(N
);
632 end Expand_N_Identifier
;
634 ---------------------------
635 -- Expand_N_Real_Literal --
636 ---------------------------
638 procedure Expand_N_Real_Literal
(N
: Node_Id
) is
640 if Vax_Float
(Etype
(N
)) then
641 Expand_Vax_Real_Literal
(N
);
643 end Expand_N_Real_Literal
;
645 --------------------------------
646 -- Expand_Protected_Component --
647 --------------------------------
649 procedure Expand_Protected_Component
(N
: Node_Id
) is
651 function Inside_Eliminated_Body
return Boolean;
652 -- Determine whether the current entity is inside a subprogram or an
653 -- entry which has been marked as eliminated.
655 ----------------------------
656 -- Inside_Eliminated_Body --
657 ----------------------------
659 function Inside_Eliminated_Body
return Boolean is
660 S
: Entity_Id
:= Current_Scope
;
663 while Present
(S
) loop
664 if (Ekind
(S
) = E_Entry
665 or else Ekind
(S
) = E_Entry_Family
666 or else Ekind
(S
) = E_Function
667 or else Ekind
(S
) = E_Procedure
)
668 and then Is_Eliminated
(S
)
677 end Inside_Eliminated_Body
;
679 -- Start of processing for Expand_Protected_Component
682 -- Eliminated bodies are not expanded and thus do not need privals
684 if not Inside_Eliminated_Body
then
686 Priv
: constant Entity_Id
:= Prival
(Entity
(N
));
688 Set_Entity
(N
, Priv
);
689 Set_Etype
(N
, Etype
(Priv
));
692 end Expand_Protected_Component
;
694 ---------------------
695 -- Expand_Renaming --
696 ---------------------
698 procedure Expand_Renaming
(N
: Node_Id
) is
699 E
: constant Entity_Id
:= Entity
(N
);
700 T
: constant Entity_Id
:= Etype
(N
);
703 Rewrite
(N
, New_Copy_Tree
(Renamed_Object
(E
)));
705 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
706 -- at the top level. This is needed in the packed case since we
707 -- specifically avoided expanding packed array references when the
708 -- renaming declaration was analyzed.
710 Reset_Analyzed_Flags
(N
);
711 Analyze_And_Resolve
(N
, T
);
718 -- This would be trivial, simply a test for an identifier that was a
719 -- reference to a formal, if it were not for the fact that a previous call
720 -- to Expand_Entry_Parameter will have modified the reference to the
721 -- identifier. A formal of a protected entity is rewritten as
723 -- typ!(recobj).rec.all'Constrained
725 -- where rec is a selector whose Entry_Formal link points to the formal
726 -- For a formal of a task entity, the formal is rewritten as a local
729 -- In addition, a formal that is marked volatile because it is aliased
730 -- through an address clause is rewritten as dereference as well.
732 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
733 Renamed_Obj
: Node_Id
;
736 -- Simple reference case
738 if Nkind_In
(N
, N_Identifier
, N_Expanded_Name
) then
739 if Is_Formal
(Entity
(N
)) then
742 -- Handle renamings of formal parameters and formals of tasks that
743 -- are rewritten as renamings.
745 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
then
746 Renamed_Obj
:= Get_Referenced_Object
(Renamed_Object
(Entity
(N
)));
748 if Is_Entity_Name
(Renamed_Obj
)
749 and then Is_Formal
(Entity
(Renamed_Obj
))
751 return Entity
(Renamed_Obj
);
754 Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
761 if Nkind
(N
) = N_Explicit_Dereference
then
763 P
: constant Node_Id
:= Prefix
(N
);
767 if Nkind
(P
) = N_Selected_Component
then
768 S
:= Selector_Name
(P
);
770 if Present
(Entry_Formal
(Entity
(S
))) then
771 return Entry_Formal
(Entity
(S
));
774 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
775 return Param_Entity
(Original_Node
(N
));