1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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_Eval
; use Sem_Eval
;
39 with Sem_Res
; use Sem_Res
;
40 with Sem_Util
; use Sem_Util
;
41 with Sem_Warn
; use Sem_Warn
;
42 with Sinfo
; use Sinfo
;
43 with Snames
; use Snames
;
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 Asm_Input and Asm_Output attribute references
161 and then not (Nkind
(Parent
(N
)) = N_Attribute_Reference
163 (Attribute_Name
(Parent
(N
)) = Name_Asm_Input
165 Attribute_Name
(Parent
(N
)) = Name_Asm_Output
))
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 a conditional 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 occurence 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 -- Otherwise get the value, and convert to appropriate type
196 Unchecked_Convert_To
(T
,
197 Make_Integer_Literal
(Loc
,
198 Intval
=> Expr_Rep_Value
(Val
))));
201 Analyze_And_Resolve
(N
, T
);
202 Set_Is_Static_Expression
(N
, False);
204 end Expand_Current_Value
;
206 -------------------------
207 -- Expand_Discriminant --
208 -------------------------
210 procedure Expand_Discriminant
(N
: Node_Id
) is
211 Scop
: constant Entity_Id
:= Scope
(Entity
(N
));
213 Parent_P
: Node_Id
:= Parent
(P
);
214 In_Entry
: Boolean := False;
217 -- The Incomplete_Or_Private_Kind happens while resolving the
218 -- discriminant constraint involved in a derived full type,
221 -- type D is private;
222 -- type D(C : ...) is new T(C);
224 if Ekind
(Scop
) = E_Record_Type
225 or Ekind
(Scop
) in Incomplete_Or_Private_Kind
227 -- Find the origin by walking up the tree till the component
230 while Present
(Parent_P
)
231 and then Nkind
(Parent_P
) /= N_Component_Declaration
234 Parent_P
:= Parent
(P
);
237 -- If the discriminant reference was part of the default expression
238 -- it has to be "discriminalized"
240 if Present
(Parent_P
) and then P
= Expression
(Parent_P
) then
241 Set_Entity
(N
, Discriminal
(Entity
(N
)));
244 elsif Is_Concurrent_Type
(Scop
) then
245 while Present
(Parent_P
)
246 and then Nkind
(Parent_P
) /= N_Subprogram_Body
250 if Nkind
(P
) = N_Entry_Declaration
then
254 Parent_P
:= Parent
(Parent_P
);
257 -- If the discriminant occurs within the default expression for a
258 -- formal of an entry or protected operation, create a default
259 -- function for it, and replace the discriminant with a reference to
260 -- the discriminant of the formal of the default function. The
261 -- discriminant entity is the one defined in the corresponding
264 if Present
(Parent_P
)
265 and then Present
(Corresponding_Spec
(Parent_P
))
268 Loc
: constant Source_Ptr
:= Sloc
(N
);
269 D_Fun
: constant Entity_Id
:= Corresponding_Spec
(Parent_P
);
270 Formal
: constant Entity_Id
:= First_Formal
(D_Fun
);
275 -- Verify that we are within a default function: the type of
276 -- its formal parameter is the same task or protected type.
279 and then Etype
(Formal
) = Scope
(Entity
(N
))
281 Disc
:= CR_Discriminant
(Entity
(N
));
284 Make_Selected_Component
(Loc
,
285 Prefix
=> New_Occurrence_Of
(Formal
, Loc
),
286 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
288 Set_Etype
(New_N
, Etype
(N
));
292 Set_Entity
(N
, Discriminal
(Entity
(N
)));
296 elsif Nkind
(Parent
(N
)) = N_Range
299 Set_Entity
(N
, CR_Discriminant
(Entity
(N
)));
301 Set_Entity
(N
, Discriminal
(Entity
(N
)));
305 Set_Entity
(N
, Discriminal
(Entity
(N
)));
307 end Expand_Discriminant
;
309 -----------------------------
310 -- Expand_Entity_Reference --
311 -----------------------------
313 procedure Expand_Entity_Reference
(N
: Node_Id
) is
314 E
: constant Entity_Id
:= Entity
(N
);
317 -- Defend against errors
319 if No
(E
) and then Total_Errors_Detected
/= 0 then
323 if Ekind
(E
) = E_Discriminant
then
324 Expand_Discriminant
(N
);
326 elsif Is_Entry_Formal
(E
) then
327 Expand_Entry_Parameter
(N
);
329 elsif Ekind
(E
) = E_Component
330 and then Is_Protected_Private
(E
)
332 -- Protect against junk use of tasking in no run time mode
334 if No_Run_Time_Mode
then
338 Expand_Protected_Private
(N
);
340 elsif Ekind
(E
) = E_Entry_Index_Parameter
then
341 Expand_Entry_Index_Parameter
(N
);
343 elsif Is_Formal
(E
) then
346 elsif Is_Renaming_Of_Object
(E
) then
349 elsif Ekind
(E
) = E_Variable
350 and then Is_Shared_Passive
(E
)
352 Expand_Shared_Passive_Variable
(N
);
355 -- Interpret possible Current_Value for variable case
357 if (Ekind
(E
) = E_Variable
359 Ekind
(E
) = E_In_Out_Parameter
361 Ekind
(E
) = E_Out_Parameter
)
362 and then Present
(Current_Value
(E
))
364 Expand_Current_Value
(N
);
366 -- We do want to warn for the case of a boolean variable (not a
367 -- boolean constant) whose value is known at compile time.
369 if Is_Boolean_Type
(Etype
(N
)) then
370 Warn_On_Known_Condition
(N
);
373 -- Don't mess with Current_Value for compile time known values. Not
374 -- only is it unnecessary, but we could disturb an indication of a
375 -- static value, which could cause semantic trouble.
377 elsif Compile_Time_Known_Value
(N
) then
380 -- Interpret possible Current_Value for constant case
382 elsif (Ekind
(E
) = E_Constant
384 Ekind
(E
) = E_In_Parameter
386 Ekind
(E
) = E_Loop_Parameter
)
387 and then Present
(Current_Value
(E
))
389 Expand_Current_Value
(N
);
391 end Expand_Entity_Reference
;
393 ----------------------------------
394 -- Expand_Entry_Index_Parameter --
395 ----------------------------------
397 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
) is
399 Set_Entity
(N
, Entry_Index_Constant
(Entity
(N
)));
400 end Expand_Entry_Index_Parameter
;
402 ----------------------------
403 -- Expand_Entry_Parameter --
404 ----------------------------
406 procedure Expand_Entry_Parameter
(N
: Node_Id
) is
407 Loc
: constant Source_Ptr
:= Sloc
(N
);
408 Ent_Formal
: constant Entity_Id
:= Entity
(N
);
409 Ent_Spec
: constant Entity_Id
:= Scope
(Ent_Formal
);
410 Parm_Type
: constant Entity_Id
:= Entry_Parameters_Type
(Ent_Spec
);
411 Acc_Stack
: constant Elist_Id
:= Accept_Address
(Ent_Spec
);
412 Addr_Ent
: constant Entity_Id
:= Node
(Last_Elmt
(Acc_Stack
));
413 P_Comp_Ref
: Entity_Id
;
415 function In_Assignment_Context
(N
: Node_Id
) return Boolean;
416 -- Check whether this is a context in which the entry formal may be
419 ---------------------------
420 -- In_Assignment_Context --
421 ---------------------------
423 function In_Assignment_Context
(N
: Node_Id
) return Boolean is
425 if Nkind
(Parent
(N
)) = N_Procedure_Call_Statement
426 or else Nkind
(Parent
(N
)) = N_Entry_Call_Statement
428 (Nkind
(Parent
(N
)) = N_Assignment_Statement
429 and then N
= Name
(Parent
(N
)))
433 elsif Nkind
(Parent
(N
)) = N_Parameter_Association
then
434 return In_Assignment_Context
(Parent
(N
));
436 elsif (Nkind
(Parent
(N
)) = N_Selected_Component
437 or else Nkind
(Parent
(N
)) = N_Indexed_Component
438 or else Nkind
(Parent
(N
)) = N_Slice
)
439 and then In_Assignment_Context
(Parent
(N
))
445 end In_Assignment_Context
;
447 -- Start of processing for Expand_Entry_Parameter
450 if Is_Task_Type
(Scope
(Ent_Spec
))
451 and then Comes_From_Source
(Ent_Formal
)
453 -- Before replacing the formal with the local renaming that is used
454 -- in the accept block, note if this is an assignment context, and
455 -- note the modification to avoid spurious warnings, because the
456 -- original entity is not used further. If formal is unconstrained,
457 -- we also generate an extra parameter to hold the Constrained
458 -- attribute of the actual. No renaming is generated for this flag.
460 if Ekind
(Entity
(N
)) /= E_In_Parameter
461 and then In_Assignment_Context
(N
)
463 Note_Possible_Modification
(N
);
466 Rewrite
(N
, New_Occurrence_Of
(Renamed_Object
(Entity
(N
)), Loc
));
470 -- What we need is a reference to the corresponding component of the
471 -- parameter record object. The Accept_Address field of the entry entity
472 -- references the address variable that contains the address of the
473 -- accept parameters record. We first have to do an unchecked conversion
474 -- to turn this into a pointer to the parameter record and then we
475 -- select the required parameter field.
478 Make_Selected_Component
(Loc
,
480 Make_Explicit_Dereference
(Loc
,
481 Unchecked_Convert_To
(Parm_Type
,
482 New_Reference_To
(Addr_Ent
, Loc
))),
484 New_Reference_To
(Entry_Component
(Ent_Formal
), Loc
));
486 -- For all types of parameters, the constructed parameter record object
487 -- contains a pointer to the parameter. Thus we must dereference them to
488 -- access them (this will often be redundant, since the needed deference
489 -- is implicit, but no harm is done by making it explicit).
492 Make_Explicit_Dereference
(Loc
, P_Comp_Ref
));
495 end Expand_Entry_Parameter
;
501 procedure Expand_Formal
(N
: Node_Id
) is
502 E
: constant Entity_Id
:= Entity
(N
);
503 Scop
: constant Entity_Id
:= Scope
(E
);
506 -- Check whether the subprogram of which this is a formal is
507 -- a protected operation. The initialization procedure for
508 -- the corresponding record type is not itself a protected operation.
510 if Is_Protected_Type
(Scope
(Scop
))
511 and then not Is_Init_Proc
(Scop
)
512 and then Present
(Protected_Formal
(E
))
514 Set_Entity
(N
, Protected_Formal
(E
));
518 ----------------------------
519 -- Expand_N_Expanded_Name --
520 ----------------------------
522 procedure Expand_N_Expanded_Name
(N
: Node_Id
) is
524 Expand_Entity_Reference
(N
);
525 end Expand_N_Expanded_Name
;
527 -------------------------
528 -- Expand_N_Identifier --
529 -------------------------
531 procedure Expand_N_Identifier
(N
: Node_Id
) is
533 Expand_Entity_Reference
(N
);
534 end Expand_N_Identifier
;
536 ---------------------------
537 -- Expand_N_Real_Literal --
538 ---------------------------
540 procedure Expand_N_Real_Literal
(N
: Node_Id
) is
542 if Vax_Float
(Etype
(N
)) then
543 Expand_Vax_Real_Literal
(N
);
545 end Expand_N_Real_Literal
;
547 ------------------------------
548 -- Expand_Protected_Private --
549 ------------------------------
551 procedure Expand_Protected_Private
(N
: Node_Id
) is
552 Loc
: constant Source_Ptr
:= Sloc
(N
);
553 E
: constant Entity_Id
:= Entity
(N
);
554 Op
: constant Node_Id
:= Protected_Operation
(E
);
561 if Nkind
(Op
) /= N_Subprogram_Body
562 or else Nkind
(Specification
(Op
)) /= N_Function_Specification
564 Set_Ekind
(Prival
(E
), E_Variable
);
566 Set_Ekind
(Prival
(E
), E_Constant
);
569 -- If the private component appears in an assignment (either lhs or
570 -- rhs) and is a one-dimensional array constrained by a discriminant,
571 -- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
572 -- is directly visible. This solves delicate visibility problems.
574 if Comes_From_Source
(N
)
575 and then Is_Array_Type
(Etype
(E
))
576 and then Number_Dimensions
(Etype
(E
)) = 1
577 and then not Within_Init_Proc
579 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Etype
(E
))));
580 Hi
:= Type_High_Bound
(Etype
(First_Index
(Etype
(E
))));
582 if Nkind
(Parent
(N
)) = N_Assignment_Statement
583 and then ((Is_Entity_Name
(Lo
)
584 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
)
585 or else (Is_Entity_Name
(Hi
)
587 Ekind
(Entity
(Hi
)) = E_In_Parameter
))
589 D_Range
:= New_Node
(N_Range
, Loc
);
591 if Is_Entity_Name
(Lo
)
592 and then Ekind
(Entity
(Lo
)) = E_In_Parameter
594 Set_Low_Bound
(D_Range
,
595 Make_Identifier
(Loc
, Chars
(Entity
(Lo
))));
597 Set_Low_Bound
(D_Range
, Duplicate_Subexpr
(Lo
));
600 if Is_Entity_Name
(Hi
)
601 and then Ekind
(Entity
(Hi
)) = E_In_Parameter
603 Set_High_Bound
(D_Range
,
604 Make_Identifier
(Loc
, Chars
(Entity
(Hi
))));
606 Set_High_Bound
(D_Range
, Duplicate_Subexpr
(Hi
));
611 Prefix
=> New_Occurrence_Of
(E
, Loc
),
612 Discrete_Range
=> D_Range
));
614 Analyze_And_Resolve
(N
, Etype
(E
));
619 -- The type of the reference is the type of the prival, which may differ
620 -- from that of the original component if it is an itype.
622 Set_Entity
(N
, Prival
(E
));
623 Set_Etype
(N
, Etype
(Prival
(E
)));
624 Scop
:= Current_Scope
;
626 -- Find entity for protected operation, which must be on scope stack
628 while not Is_Protected_Type
(Scope
(Scop
)) loop
629 Scop
:= Scope
(Scop
);
632 Append_Elmt
(N
, Privals_Chain
(Scop
));
633 end Expand_Protected_Private
;
635 ---------------------
636 -- Expand_Renaming --
637 ---------------------
639 procedure Expand_Renaming
(N
: Node_Id
) is
640 E
: constant Entity_Id
:= Entity
(N
);
641 T
: constant Entity_Id
:= Etype
(N
);
644 Rewrite
(N
, New_Copy_Tree
(Renamed_Object
(E
)));
646 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
647 -- at the top level. This is needed in the packed case since we
648 -- specifically avoided expanding packed array references when the
649 -- renaming declaration was analyzed.
651 Reset_Analyzed_Flags
(N
);
652 Analyze_And_Resolve
(N
, T
);
659 -- This would be trivial, simply a test for an identifier that was a
660 -- reference to a formal, if it were not for the fact that a previous call
661 -- to Expand_Entry_Parameter will have modified the reference to the
662 -- identifier. A formal of a protected entity is rewritten as
664 -- typ!(recobj).rec.all'Constrained
666 -- where rec is a selector whose Entry_Formal link points to the formal
667 -- For a formal of a task entity, the formal is rewritten as a local
670 -- In addition, a formal that is marked volatile because it is aliased
671 -- through an address clause is rewritten as dereference as well.
673 function Param_Entity
(N
: Node_Id
) return Entity_Id
is
675 -- Simple reference case
677 if Nkind
(N
) = N_Identifier
or else Nkind
(N
) = N_Expanded_Name
then
678 if Is_Formal
(Entity
(N
)) then
681 elsif Nkind
(Parent
(Entity
(N
))) = N_Object_Renaming_Declaration
682 and then Nkind
(Parent
(Parent
(Entity
(N
)))) = N_Accept_Statement
688 if Nkind
(N
) = N_Explicit_Dereference
then
690 P
: constant Node_Id
:= Prefix
(N
);
694 if Nkind
(P
) = N_Selected_Component
then
695 S
:= Selector_Name
(P
);
697 if Present
(Entry_Formal
(Entity
(S
))) then
698 return Entry_Formal
(Entity
(S
));
701 elsif Nkind
(Original_Node
(N
)) = N_Identifier
then
702 return Param_Entity
(Original_Node
(N
));