1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Exp_Smem
; use Exp_Smem
;
32 with Exp_Tss
; use Exp_Tss
;
33 with Exp_Util
; use Exp_Util
;
34 with Namet
; use Namet
;
35 with Nmake
; use Nmake
;
37 with Output
; use Output
;
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 Sinput
; use Sinput
;
45 with Snames
; use Snames
;
46 with Tbuild
; use Tbuild
;
48 package body Exp_Ch2
is
50 -----------------------
51 -- Local Subprograms --
52 -----------------------
54 procedure Expand_Current_Value
(N
: Node_Id
);
55 -- N is a node for a variable whose Current_Value field is set. If N is
56 -- node is for a discrete type, replaces node with a copy of the referenced
57 -- value. This provides a limited form of value propagation for variables
58 -- which are initialized or assigned not been further modified at the time
59 -- of reference. The call has no effect if the Current_Value refers to a
60 -- conditional with condition other than equality.
62 procedure Expand_Discriminant
(N
: Node_Id
);
63 -- An occurrence of a discriminant within a discriminated type is replaced
64 -- with the corresponding discriminal, that is to say the formal parameter
65 -- of the initialization procedure for the type that is associated with
66 -- that particular discriminant. This replacement is not performed for
67 -- discriminants of records that appear in constraints of component of the
68 -- record, because Gigi uses the discriminant name to retrieve its value.
69 -- In the other hand, it has to be performed for default expressions of
70 -- components because they are used in the record init procedure. See Einfo
71 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
72 -- discriminants of tasks and protected types, the transformation is more
73 -- complex when it occurs within a default expression for an entry or
74 -- protected operation. The corresponding default_expression_function has
75 -- an additional parameter which is the target of an entry call, and the
76 -- discriminant of the task must be replaced with a reference to the
77 -- discriminant of that formal parameter.
79 procedure Expand_Entity_Reference
(N
: Node_Id
);
80 -- Common processing for expansion of identifiers and expanded names
81 -- Dispatches to specific expansion procedures.
83 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
);
84 -- A reference to the identifier in the entry index specification of an
85 -- entry body is modified to a reference to a constant definition equal to
86 -- the index of the entry family member being called. This constant is
87 -- calculated as part of the elaboration of the expanded code for the body,
88 -- and is calculated from the object-wide entry index returned by Next_
91 procedure Expand_Entry_Parameter
(N
: Node_Id
);
92 -- A reference to an entry parameter is modified to be a reference to the
93 -- corresponding component of the entry parameter record that is passed by
94 -- the runtime to the accept body procedure.
96 procedure Expand_Formal
(N
: Node_Id
);
97 -- A reference to a formal parameter of a protected subprogram is expanded
98 -- into the corresponding formal of the unprotected procedure used to
99 -- represent the operation within the protected object. In other cases
100 -- Expand_Formal is a no-op.
102 procedure Expand_Protected_Component
(N
: Node_Id
);
103 -- A reference to a private component of a protected type is expanded into
104 -- a reference to the corresponding prival in the current protected entry
107 procedure Expand_Renaming
(N
: Node_Id
);
108 -- For renamings, just replace the identifier by the corresponding
109 -- named expression. Note that this has been evaluated (see routine
110 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
111 -- the correct renaming semantics.
113 --------------------------
114 -- Expand_Current_Value --
115 --------------------------
117 procedure Expand_Current_Value
(N
: Node_Id
) is
118 Loc
: constant Source_Ptr
:= Sloc
(N
);
119 E
: constant Entity_Id
:= Entity
(N
);
120 CV
: constant Node_Id
:= Current_Value
(E
);
121 T
: constant Entity_Id
:= Etype
(N
);
128 -- No replacement if value raises constraint error
130 and then Nkind
(CV
) /= N_Raise_Constraint_Error
132 -- Do this only for discrete types
134 and then Is_Discrete_Type
(T
)
136 -- Do not replace biased types, since it is problematic to
137 -- consistently generate a sensible constant value in this case.
139 and then not Has_Biased_Representation
(T
)
141 -- Do not replace lvalues
143 and then not May_Be_Lvalue
(N
)
145 -- Check that entity is suitable for replacement
147 and then OK_To_Do_Constant_Replacement
(E
)
149 -- Do not replace occurrences in pragmas (where names typically
150 -- appear not as values, but as simply names. If there are cases
151 -- where values are required, it is only a very minor efficiency
152 -- issue that they do not get replaced when they could be).
154 and then Nkind
(Parent
(N
)) /= N_Pragma_Argument_Association
156 -- Do not replace the prefixes of attribute references, since this
157 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
158 -- Name_Asm_Output, don't do replacement anywhere, since we can have
159 -- lvalue references in the arguments.
161 and then not (Nkind
(Parent
(N
)) = N_Attribute_Reference
163 (Attribute_Name
(Parent
(N
)) in Name_Asm_Input
165 or else Prefix
(Parent
(N
)) = N
))
167 -- Case of Current_Value is a compile time known value
169 if Nkind
(CV
) in N_Subexpr
then
172 -- Case of Current_Value is an if expression reference
175 Get_Current_Value_Condition
(N
, Op
, Val
);
177 if Op
/= N_Op_Eq
then
182 -- If constant value is an occurrence of an enumeration literal,
183 -- then we just make another occurrence of the same literal.
185 if Is_Entity_Name
(Val
)
186 and then Ekind
(Entity
(Val
)) = E_Enumeration_Literal
189 Unchecked_Convert_To
(T
,
190 New_Occurrence_Of
(Entity
(Val
), Loc
)));
192 -- If constant is of a character type, just make an appropriate
193 -- character literal, which will get the proper type.
195 elsif Is_Character_Type
(T
) then
197 Make_Character_Literal
(Loc
,
198 Chars
=> Chars
(Val
),
199 Char_Literal_Value
=> Expr_Rep_Value
(Val
)));
201 -- If constant is of an integer type, just make an appropriate
202 -- integer literal, which will get the proper type.
204 elsif Is_Integer_Type
(T
) then
206 Make_Integer_Literal
(Loc
,
207 Intval
=> Expr_Rep_Value
(Val
)));
209 -- Otherwise do unchecked conversion of value to right type
213 Unchecked_Convert_To
(T
,
214 Make_Integer_Literal
(Loc
,
215 Intval
=> Expr_Rep_Value
(Val
))));
218 Analyze_And_Resolve
(N
, T
);
219 Set_Is_Static_Expression
(N
, False);
221 end Expand_Current_Value
;
223 -------------------------
224 -- Expand_Discriminant --
225 -------------------------
227 procedure Expand_Discriminant
(N
: Node_Id
) is
228 Scop
: constant Entity_Id
:= Scope
(Entity
(N
));
230 Parent_P
: Node_Id
:= Parent
(P
);
231 In_Entry
: Boolean := False;
234 -- The Incomplete_Or_Private_Kind happens while resolving the
235 -- discriminant constraint involved in a derived full type,
238 -- type D is private;
239 -- type D(C : ...) is new T(C);
241 if Ekind
(Scop
) = E_Record_Type
242 or Ekind
(Scop
) in Incomplete_Or_Private_Kind
244 -- Find the origin by walking up the tree till the component
247 while Present
(Parent_P
)
248 and then Nkind
(Parent_P
) /= N_Component_Declaration
251 Parent_P
:= Parent
(P
);
254 -- If the discriminant reference was part of the default expression
255 -- it has to be "discriminalized"
257 if Present
(Parent_P
) and then P
= Expression
(Parent_P
) then
258 Set_Entity
(N
, Discriminal
(Entity
(N
)));
261 elsif Is_Concurrent_Type
(Scop
) then
262 while Present
(Parent_P
)
263 and then Nkind
(Parent_P
) /= N_Subprogram_Body
267 if Nkind
(P
) = N_Entry_Declaration
then
271 Parent_P
:= Parent
(Parent_P
);
274 -- If the discriminant occurs within the default expression for a
275 -- formal of an entry or protected operation, replace it with a
276 -- reference to the discriminant of the formal of the enclosing
279 if Present
(Parent_P
)
280 and then Present
(Corresponding_Spec
(Parent_P
))
283 Loc
: constant Source_Ptr
:= Sloc
(N
);
284 D_Fun
: constant Entity_Id
:= Corresponding_Spec
(Parent_P
);
285 Formal
: constant Entity_Id
:= First_Formal
(D_Fun
);
290 -- Verify that we are within the body of an entry or protected
291 -- operation. Its first formal parameter is the synchronized
295 and then Etype
(Formal
) = Scope
(Entity
(N
))
297 Disc
:= CR_Discriminant
(Entity
(N
));
300 Make_Selected_Component
(Loc
,
301 Prefix
=> New_Occurrence_Of
(Formal
, Loc
),
302 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
304 Set_Etype
(New_N
, Etype
(N
));
308 Set_Entity
(N
, Discriminal
(Entity
(N
)));
312 elsif Nkind
(Parent
(N
)) = N_Range
315 Set_Entity
(N
, CR_Discriminant
(Entity
(N
)));
317 -- Finally, if the entity is the discriminant of the original
318 -- type declaration, and we are within the initialization
319 -- procedure for a task, the designated entity is the
320 -- discriminal of the task body. This can happen when the
321 -- argument of pragma Task_Name mentions a discriminant,
322 -- because the pragma is analyzed in the task declaration
323 -- but is expanded in the call to Create_Task in the init_proc.
325 elsif Within_Init_Proc
then
326 Set_Entity
(N
, Discriminal
(CR_Discriminant
(Entity
(N
))));
328 Set_Entity
(N
, Discriminal
(Entity
(N
)));
332 Set_Entity
(N
, Discriminal
(Entity
(N
)));
334 end Expand_Discriminant
;
336 -----------------------------
337 -- Expand_Entity_Reference --
338 -----------------------------
340 procedure Expand_Entity_Reference
(N
: Node_Id
) is
342 function Is_Object_Renaming_Name
(N
: Node_Id
) return Boolean;
343 -- Indicates that N occurs (after accounting for qualified expressions
344 -- and type conversions) as the name of an object renaming declaration.
345 -- We don't want to fold values in that case.
347 -----------------------------
348 -- Is_Object_Renaming_Name --
349 -----------------------------
351 function Is_Object_Renaming_Name
(N
: Node_Id
) return Boolean is
352 Trailer
: Node_Id
:= N
;
356 Rover
:= Parent
(Trailer
);
357 case Nkind
(Rover
) is
358 when N_Qualified_Expression | N_Type_Conversion
=>
359 -- Conservative for type conversions; only necessary if
360 -- conversion does not introduce a new object (as opposed
361 -- to a new view of an existing object).
363 when N_Object_Renaming_Declaration
=>
364 return Trailer
= Name
(Rover
);
366 return False; -- the usual case
370 end Is_Object_Renaming_Name
;
374 E
: constant Entity_Id
:= Entity
(N
);
376 -- Start of processing for Expand_Entity_Reference
379 -- Defend against errors
382 Check_Error_Detected
;
386 if Ekind
(E
) = E_Discriminant
then
387 Expand_Discriminant
(N
);
389 elsif Is_Entry_Formal
(E
) then
390 Expand_Entry_Parameter
(N
);
392 elsif Is_Protected_Component
(E
) then
393 if No_Run_Time_Mode
then
396 Expand_Protected_Component
(N
);
399 elsif Ekind
(E
) = E_Entry_Index_Parameter
then
400 Expand_Entry_Index_Parameter
(N
);
402 elsif Is_Formal
(E
) then
405 elsif Is_Renaming_Of_Object
(E
) then
408 elsif Ekind
(E
) = E_Variable
409 and then Is_Shared_Passive
(E
)
411 Expand_Shared_Passive_Variable
(N
);
414 -- Test code for implementing the pragma Reviewable requirement of
415 -- classifying reads of scalars as referencing potentially uninitialized
419 and then Is_Scalar_Type
(Etype
(N
))
420 and then (Is_Assignable
(E
) or else Is_Constant_Object
(E
))
421 and then Comes_From_Source
(N
)
422 and then Is_LHS
(N
) = No
423 and then not Is_Actual_Out_Parameter
(N
)
424 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
425 or else Attribute_Name
(Parent
(N
)) /= Name_Valid
)
427 Write_Location
(Sloc
(N
));
428 Write_Str
(": Read from scalar """);
429 Write_Name
(Chars
(N
));
432 if Is_Known_Valid
(E
) then
433 Write_Str
(", Is_Known_Valid");
439 -- Set Atomic_Sync_Required if necessary for atomic variable. Note that
440 -- this processing does NOT apply to Volatile_Full_Access variables.
442 if Nkind
(N
) in N_Identifier | N_Expanded_Name
443 and then Ekind
(E
) = E_Variable
444 and then (Is_Atomic
(E
) or else Is_Atomic
(Etype
(E
)))
450 -- If variable is atomic, but type is not, setting depends on
451 -- disable/enable state for the variable.
453 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
454 Set
:= not Atomic_Synchronization_Disabled
(E
);
456 -- If variable is not atomic, but its type is atomic, setting
457 -- depends on disable/enable state for the type.
459 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
460 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
462 -- Else both variable and type are atomic (see outer if), and we
463 -- disable if either variable or its type have sync disabled.
466 Set
:= (not Atomic_Synchronization_Disabled
(E
))
468 (not Atomic_Synchronization_Disabled
(Etype
(E
)));
471 -- Set flag if required
474 Activate_Atomic_Synchronization
(N
);
479 -- Interpret possible Current_Value for variable case. The
480 -- Is_Object_Renaming_Name test is needed for cases such as
482 -- Y : Integer renames Integer'(X);
483 -- where the value of Y is changed by any subsequent assignments to X.
484 -- In cases like this, we do not want to use Current_Value even though
488 and then Present
(Current_Value
(E
))
489 and then not Is_Object_Renaming_Name
(N
)
491 Expand_Current_Value
(N
);
493 -- We do want to warn for the case of a boolean variable (not a
494 -- boolean constant) whose value is known at compile time.
496 if Is_Boolean_Type
(Etype
(N
)) then
497 Warn_On_Known_Condition
(N
);
500 -- Don't mess with Current_Value for compile time known values. Not
501 -- only is it unnecessary, but we could disturb an indication of a
502 -- static value, which could cause semantic trouble.
504 elsif Compile_Time_Known_Value
(N
) then
507 -- Interpret possible Current_Value for constant case
509 elsif Is_Constant_Object
(E
)
510 and then Present
(Current_Value
(E
))
512 Expand_Current_Value
(N
);
514 end Expand_Entity_Reference
;
516 ----------------------------------
517 -- Expand_Entry_Index_Parameter --
518 ----------------------------------
520 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
) is
521 Index_Con
: constant Entity_Id
:= Entry_Index_Constant
(Entity
(N
));
523 Set_Entity
(N
, Index_Con
);
524 Set_Etype
(N
, Etype
(Index_Con
));
525 end Expand_Entry_Index_Parameter
;
527 ----------------------------
528 -- Expand_Entry_Parameter --
529 ----------------------------
531 procedure Expand_Entry_Parameter
(N
: Node_Id
) is
532 Loc
: constant Source_Ptr
:= Sloc
(N
);
533 Ent_Formal
: constant Entity_Id
:= Entity
(N
);
534 Ent_Spec
: constant Entity_Id
:= Scope
(Ent_Formal
);
535 Parm_Type
: constant Entity_Id
:= Entry_Parameters_Type
(Ent_Spec
);
536 Acc_Stack
: constant Elist_Id
:= Accept_Address
(Ent_Spec
);
537 Addr_Ent
: constant Entity_Id
:= Node
(Last_Elmt
(Acc_Stack
));
538 P_Comp_Ref
: Entity_Id
;
540 function In_Assignment_Context
(N
: Node_Id
) return Boolean;
541 -- Check whether this is a context in which the entry formal may be
544 ---------------------------
545 -- In_Assignment_Context --
546 ---------------------------
548 function In_Assignment_Context
(N
: Node_Id
) return Boolean is
550 -- Case of use in a call
552 -- ??? passing a formal as actual for a mode IN formal is
553 -- considered as an assignment?
555 if Nkind
(Parent
(N
)) in
556 N_Procedure_Call_Statement | N_Entry_Call_Statement
557 or else (Nkind
(Parent
(N
)) = N_Assignment_Statement
558 and then N
= Name
(Parent
(N
)))
562 -- Case of a parameter association: climb up to enclosing call
564 elsif Nkind
(Parent
(N
)) = N_Parameter_Association
then
565 return In_Assignment_Context
(Parent
(N
));
567 -- Case of a selected component, indexed component or slice prefix:
568 -- climb up the tree, unless the prefix is of an access type (in
569 -- which case there is an implicit dereference, and the formal itself
570 -- is not being assigned to).
572 elsif Nkind
(Parent
(N
)) in
573 N_Selected_Component | N_Indexed_Component | N_Slice
574 and then N
= Prefix
(Parent
(N
))
575 and then not Is_Access_Type
(Etype
(N
))
576 and then In_Assignment_Context
(Parent
(N
))
583 end In_Assignment_Context
;
585 -- Start of processing for Expand_Entry_Parameter
588 if Is_Task_Type
(Scope
(Ent_Spec
))
589 and then Comes_From_Source
(Ent_Formal
)
591 -- Before replacing the formal with the local renaming that is used
592 -- in the accept block, note if this is an assignment context, and
593 -- note the modification to avoid spurious warnings, because the
594 -- original entity is not used further. If formal is unconstrained,
595 -- we also generate an extra parameter to hold the Constrained
596 -- attribute of the actual. No renaming is generated for this flag.
598 -- Calling Note_Possible_Modification in the expander is dubious,
599 -- because this generates a cross-reference entry, and should be
600 -- done during semantic processing so it is called in -gnatc mode???
602 if Ekind
(Entity
(N
)) /= E_In_Parameter
603 and then In_Assignment_Context
(N
)
605 Note_Possible_Modification
(N
, Sure
=> True);
609 -- What we need is a reference to the corresponding component of the
610 -- parameter record object. The Accept_Address field of the entry entity
611 -- references the address variable that contains the address of the
612 -- accept parameters record. We first have to do an unchecked conversion
613 -- to turn this into a pointer to the parameter record and then we
614 -- select the required parameter field.
616 -- The same processing applies to protected entries, where the Accept_
617 -- Address is also the address of the Parameters record.
620 Make_Selected_Component
(Loc
,
622 Make_Explicit_Dereference
(Loc
,
623 Unchecked_Convert_To
(Parm_Type
,
624 New_Occurrence_Of
(Addr_Ent
, Loc
))),
626 New_Occurrence_Of
(Entry_Component
(Ent_Formal
), Loc
));
628 -- For all types of parameters, the constructed parameter record object
629 -- contains a pointer to the parameter. Thus we must dereference them to
630 -- access them (this will often be redundant, since the dereference is
631 -- implicit, but no harm is done by making it explicit).
634 Make_Explicit_Dereference
(Loc
, P_Comp_Ref
));
637 end Expand_Entry_Parameter
;
643 procedure Expand_Formal
(N
: Node_Id
) is
644 E
: constant Entity_Id
:= Entity
(N
);
645 Scop
: constant Entity_Id
:= Scope
(E
);
648 -- Check whether the subprogram of which this is a formal is
649 -- a protected operation. The initialization procedure for
650 -- the corresponding record type is not itself a protected operation.
652 if Is_Protected_Type
(Scope
(Scop
))
653 and then not Is_Init_Proc
(Scop
)
654 and then Present
(Protected_Formal
(E
))
656 Set_Entity
(N
, Protected_Formal
(E
));
660 ----------------------------
661 -- Expand_N_Expanded_Name --
662 ----------------------------
664 procedure Expand_N_Expanded_Name
(N
: Node_Id
) is
666 Expand_Entity_Reference
(N
);
667 end Expand_N_Expanded_Name
;
669 -------------------------
670 -- Expand_N_Identifier --
671 -------------------------
673 procedure Expand_N_Identifier
(N
: Node_Id
) is
675 Expand_Entity_Reference
(N
);
676 end Expand_N_Identifier
;
678 ---------------------------
679 -- Expand_N_Real_Literal --
680 ---------------------------
682 procedure Expand_N_Real_Literal
(N
: Node_Id
) is
683 pragma Unreferenced
(N
);
686 -- Historically, this routine existed because there were expansion
687 -- requirements for Vax real literals, but now Vax real literals
688 -- are now handled by gigi, so this routine no longer does anything.
691 end Expand_N_Real_Literal
;
693 --------------------------------
694 -- Expand_Protected_Component --
695 --------------------------------
697 procedure Expand_Protected_Component
(N
: Node_Id
) is
699 function Inside_Eliminated_Body
return Boolean;
700 -- Determine whether the current entity is inside a subprogram or an
701 -- entry which has been marked as eliminated.
703 ----------------------------
704 -- Inside_Eliminated_Body --
705 ----------------------------
707 function Inside_Eliminated_Body
return Boolean is
708 S
: Entity_Id
:= Current_Scope
;
711 while Present
(S
) loop
712 if (Ekind
(S
) = E_Entry
713 or else Ekind
(S
) = E_Entry_Family
714 or else Ekind
(S
) = E_Function
715 or else Ekind
(S
) = E_Procedure
)
716 and then Is_Eliminated
(S
)
725 end Inside_Eliminated_Body
;
727 -- Start of processing for Expand_Protected_Component
730 -- Eliminated bodies are not expanded and thus do not need privals
732 if not Inside_Eliminated_Body
then
734 Priv
: constant Entity_Id
:= Prival
(Entity
(N
));
736 Set_Entity
(N
, Priv
);
737 Set_Etype
(N
, Etype
(Priv
));
740 end Expand_Protected_Component
;
742 ---------------------
743 -- Expand_Renaming --
744 ---------------------
746 procedure Expand_Renaming
(N
: Node_Id
) is
747 E
: constant Entity_Id
:= Entity
(N
);
748 T
: constant Entity_Id
:= Etype
(N
);
751 Rewrite
(N
, New_Copy_Tree
(Renamed_Object
(E
)));
753 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
754 -- at the top level. This is needed in the packed case since we
755 -- specifically avoided expanding packed array references when the
756 -- renaming declaration was analyzed.
758 Reset_Analyzed_Flags
(N
);
759 Analyze_And_Resolve
(N
, T
);