1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Exp_Smem
; use Exp_Smem
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Namet
; use Namet
;
38 with Nlists
; use Nlists
;
39 with Nmake
; use Nmake
;
41 with Output
; use Output
;
42 with Rtsfind
; use Rtsfind
;
44 with Sem_Eval
; use Sem_Eval
;
45 with Sem_Res
; use Sem_Res
;
46 with Sem_Util
; use Sem_Util
;
47 with Sem_Warn
; use Sem_Warn
;
48 with Sinfo
; use Sinfo
;
49 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
50 with Sinfo
.Utils
; use Sinfo
.Utils
;
51 with Sinput
; use Sinput
;
52 with Snames
; use Snames
;
54 with Tbuild
; use Tbuild
;
56 package body Exp_Ch2
is
58 -----------------------
59 -- Local Subprograms --
60 -----------------------
62 procedure Expand_Current_Value
(N
: Node_Id
);
63 -- N is a node for a variable whose Current_Value field is set. If N is
64 -- node is for a discrete type, replaces node with a copy of the referenced
65 -- value. This provides a limited form of value propagation for variables
66 -- which are initialized or assigned not been further modified at the time
67 -- of reference. The call has no effect if the Current_Value refers to a
68 -- conditional with condition other than equality.
70 procedure Expand_Discriminant
(N
: Node_Id
);
71 -- An occurrence of a discriminant within a discriminated type is replaced
72 -- with the corresponding discriminal, that is to say the formal parameter
73 -- of the initialization procedure for the type that is associated with
74 -- that particular discriminant. This replacement is not performed for
75 -- discriminants of records that appear in constraints of component of the
76 -- record, because Gigi uses the discriminant name to retrieve its value.
77 -- In the other hand, it has to be performed for default expressions of
78 -- components because they are used in the record init procedure. See Einfo
79 -- for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
80 -- discriminants of tasks and protected types, the transformation is more
81 -- complex when it occurs within a default expression for an entry or
82 -- protected operation. The corresponding default_expression_function has
83 -- an additional parameter which is the target of an entry call, and the
84 -- discriminant of the task must be replaced with a reference to the
85 -- discriminant of that formal parameter.
87 procedure Expand_Entity_Reference
(N
: Node_Id
);
88 -- Common processing for expansion of identifiers and expanded names
89 -- Dispatches to specific expansion procedures.
91 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
);
92 -- A reference to the identifier in the entry index specification of an
93 -- entry body is modified to a reference to a constant definition equal to
94 -- the index of the entry family member being called. This constant is
95 -- calculated as part of the elaboration of the expanded code for the body,
96 -- and is calculated from the object-wide entry index returned by Next_
99 procedure Expand_Entry_Parameter
(N
: Node_Id
);
100 -- A reference to an entry parameter is modified to be a reference to the
101 -- corresponding component of the entry parameter record that is passed by
102 -- the runtime to the accept body procedure.
104 procedure Expand_Formal
(N
: Node_Id
);
105 -- A reference to a formal parameter of a protected subprogram is expanded
106 -- into the corresponding formal of the unprotected procedure used to
107 -- represent the operation within the protected object. In other cases
108 -- Expand_Formal is a no-op.
110 procedure Expand_Protected_Component
(N
: Node_Id
);
111 -- A reference to a private component of a protected type is expanded into
112 -- a reference to the corresponding prival in the current protected entry
115 procedure Expand_Renaming
(N
: Node_Id
);
116 -- For renamings, just replace the identifier by the corresponding
117 -- named expression. Note that this has been evaluated (see routine
118 -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
119 -- the correct renaming semantics.
121 --------------------------
122 -- Expand_Current_Value --
123 --------------------------
125 procedure Expand_Current_Value
(N
: Node_Id
) is
126 Loc
: constant Source_Ptr
:= Sloc
(N
);
127 E
: constant Entity_Id
:= Entity
(N
);
128 CV
: constant Node_Id
:= Current_Value
(E
);
129 T
: constant Entity_Id
:= Etype
(N
);
136 -- No replacement if value raises constraint error
138 and then Nkind
(CV
) /= N_Raise_Constraint_Error
140 -- Do this only for discrete types
142 and then Is_Discrete_Type
(T
)
144 -- Do not replace biased types, since it is problematic to
145 -- consistently generate a sensible constant value in this case.
147 and then not Has_Biased_Representation
(T
)
149 -- Do not replace lvalues
151 and then not Known_To_Be_Assigned
(N
)
153 -- Check that entity is suitable for replacement
155 and then OK_To_Do_Constant_Replacement
(E
)
157 -- Do not replace the prefixes of attribute references, since this
158 -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and
159 -- Name_Asm_Output, don't do replacement anywhere, since we can have
160 -- lvalue references in the arguments.
162 and then not (Nkind
(Parent
(N
)) = N_Attribute_Reference
164 (Attribute_Name
(Parent
(N
)) in Name_Asm_Input
166 or else Prefix
(Parent
(N
)) = N
))
168 -- Case of Current_Value is a compile time known value
170 if Nkind
(CV
) in N_Subexpr
then
173 -- Case of Current_Value is an if expression reference
176 Get_Current_Value_Condition
(N
, Op
, Val
);
178 if Op
/= N_Op_Eq
then
183 -- If constant value is an occurrence of an enumeration literal,
184 -- then we just make another occurrence of the same literal.
186 if Is_Entity_Name
(Val
)
187 and then Ekind
(Entity
(Val
)) = E_Enumeration_Literal
190 Unchecked_Convert_To
(T
,
191 New_Occurrence_Of
(Entity
(Val
), Loc
)));
193 -- If constant is of a character type, just make an appropriate
194 -- character literal, which will get the proper type.
196 elsif Is_Character_Type
(T
) then
198 Make_Character_Literal
(Loc
,
199 Chars
=> Chars
(Val
),
200 Char_Literal_Value
=> Expr_Rep_Value
(Val
)));
202 -- If constant is of an integer type, just make an appropriate
203 -- integer literal, which will get the proper type.
205 elsif Is_Integer_Type
(T
) then
207 Make_Integer_Literal
(Loc
,
208 Intval
=> Expr_Rep_Value
(Val
)));
210 -- Otherwise do unchecked conversion of value to right type
214 Unchecked_Convert_To
(T
,
215 Make_Integer_Literal
(Loc
,
216 Intval
=> Expr_Rep_Value
(Val
))));
219 Analyze_And_Resolve
(N
, T
);
220 Set_Is_Static_Expression
(N
, False);
222 end Expand_Current_Value
;
224 -------------------------
225 -- Expand_Discriminant --
226 -------------------------
228 procedure Expand_Discriminant
(N
: Node_Id
) is
229 Scop
: constant Entity_Id
:= Scope
(Entity
(N
));
231 Parent_P
: Node_Id
:= Parent
(P
);
232 In_Entry
: Boolean := False;
235 -- The Incomplete_Or_Private_Kind happens while resolving the
236 -- discriminant constraint involved in a derived full type,
239 -- type D is private;
240 -- type D(C : ...) is new T(C);
242 if Ekind
(Scop
) = E_Record_Type
243 or Ekind
(Scop
) in Incomplete_Or_Private_Kind
245 -- Find the origin by walking up the tree till the component
248 while Present
(Parent_P
)
249 and then Nkind
(Parent_P
) /= N_Component_Declaration
252 Parent_P
:= Parent
(P
);
255 -- If the discriminant reference was part of the default expression
256 -- it has to be "discriminalized"
258 if Present
(Parent_P
) and then P
= Expression
(Parent_P
) then
259 Set_Entity
(N
, Discriminal
(Entity
(N
)));
262 elsif Is_Concurrent_Type
(Scop
) then
263 while Present
(Parent_P
)
264 and then Nkind
(Parent_P
) /= N_Subprogram_Body
268 if Nkind
(P
) = N_Entry_Declaration
then
272 Parent_P
:= Parent
(Parent_P
);
275 -- If the discriminant occurs within the default expression for a
276 -- formal of an entry or protected operation, replace it with a
277 -- reference to the discriminant of the formal of the enclosing
280 if Present
(Parent_P
)
281 and then Present
(Corresponding_Spec
(Parent_P
))
284 Loc
: constant Source_Ptr
:= Sloc
(N
);
285 D_Fun
: constant Entity_Id
:= Corresponding_Spec
(Parent_P
);
286 Formal
: constant Entity_Id
:= First_Formal
(D_Fun
);
291 -- Verify that we are within the body of an entry or protected
292 -- operation. Its first formal parameter is the synchronized
296 and then Etype
(Formal
) = Scope
(Entity
(N
))
298 Disc
:= CR_Discriminant
(Entity
(N
));
301 Make_Selected_Component
(Loc
,
302 Prefix
=> New_Occurrence_Of
(Formal
, Loc
),
303 Selector_Name
=> New_Occurrence_Of
(Disc
, Loc
));
305 Set_Etype
(New_N
, Etype
(N
));
309 Set_Entity
(N
, Discriminal
(Entity
(N
)));
313 elsif Nkind
(Parent
(N
)) = N_Range
316 Set_Entity
(N
, CR_Discriminant
(Entity
(N
)));
318 -- Finally, if the entity is the discriminant of the original
319 -- type declaration, and we are within the initialization
320 -- procedure for a task, the designated entity is the
321 -- discriminal of the task body. This can happen when the
322 -- argument of pragma Task_Name mentions a discriminant,
323 -- because the pragma is analyzed in the task declaration
324 -- but is expanded in the call to Create_Task in the init_proc.
326 elsif Within_Init_Proc
then
327 Set_Entity
(N
, Discriminal
(CR_Discriminant
(Entity
(N
))));
329 Set_Entity
(N
, Discriminal
(Entity
(N
)));
333 Set_Entity
(N
, Discriminal
(Entity
(N
)));
335 end Expand_Discriminant
;
337 -----------------------------
338 -- Expand_Entity_Reference --
339 -----------------------------
341 procedure Expand_Entity_Reference
(N
: Node_Id
) is
343 function Is_Object_Renaming_Name
(N
: Node_Id
) return Boolean;
344 -- Indicates that N occurs (after accounting for qualified expressions
345 -- and type conversions) as the name of an object renaming declaration.
346 -- We don't want to fold values in that case.
348 -----------------------------
349 -- Is_Object_Renaming_Name --
350 -----------------------------
352 function Is_Object_Renaming_Name
(N
: Node_Id
) return Boolean is
353 Trailer
: Node_Id
:= N
;
357 Rover
:= Parent
(Trailer
);
358 case Nkind
(Rover
) is
359 when N_Qualified_Expression | N_Type_Conversion
=>
360 -- Conservative for type conversions; only necessary if
361 -- conversion does not introduce a new object (as opposed
362 -- to a new view of an existing object).
364 when N_Object_Renaming_Declaration
=>
365 return Trailer
= Name
(Rover
);
367 return False; -- the usual case
371 end Is_Object_Renaming_Name
;
375 E
: constant Entity_Id
:= Entity
(N
);
377 -- Start of processing for Expand_Entity_Reference
380 -- Defend against errors
383 Check_Error_Detected
;
387 if Ekind
(E
) = E_Discriminant
then
388 Expand_Discriminant
(N
);
390 elsif Is_Entry_Formal
(E
) then
391 Expand_Entry_Parameter
(N
);
393 elsif Is_Protected_Component
(E
) then
394 if No_Run_Time_Mode
then
397 Expand_Protected_Component
(N
);
400 elsif Ekind
(E
) = E_Entry_Index_Parameter
then
401 Expand_Entry_Index_Parameter
(N
);
403 elsif Is_Formal
(E
) then
406 elsif Is_Renaming_Of_Object
(E
) then
409 elsif Ekind
(E
) = E_Variable
410 and then Is_Shared_Passive
(E
)
412 Expand_Shared_Passive_Variable
(N
);
415 -- Test code for implementing the pragma Reviewable requirement of
416 -- classifying reads of scalars as referencing potentially uninitialized
420 and then Is_Scalar_Type
(Etype
(N
))
421 and then (Is_Assignable
(E
) or else Is_Constant_Object
(E
))
422 and then Comes_From_Source
(N
)
423 and then not Known_To_Be_Assigned
(N
)
424 and then not Is_Actual_Out_Parameter
(N
)
425 and then (Nkind
(Parent
(N
)) /= N_Attribute_Reference
426 or else Attribute_Name
(Parent
(N
)) /= Name_Valid
)
428 Write_Location
(Sloc
(N
));
429 Write_Str
(": Read from scalar """);
430 Write_Name
(Chars
(N
));
433 if Is_Known_Valid
(E
) then
434 Write_Str
(", Is_Known_Valid");
440 -- Set Atomic_Sync_Required if necessary for atomic variable. Note that
441 -- this processing does NOT apply to Volatile_Full_Access variables.
443 if Nkind
(N
) in N_Identifier | N_Expanded_Name
444 and then Ekind
(E
) = E_Variable
445 and then (Is_Atomic
(E
) or else Is_Atomic
(Etype
(E
)))
451 -- If variable is atomic, but type is not, setting depends on
452 -- disable/enable state for the variable.
454 if Is_Atomic
(E
) and then not Is_Atomic
(Etype
(E
)) then
455 Set
:= not Atomic_Synchronization_Disabled
(E
);
457 -- If variable is not atomic, but its type is atomic, setting
458 -- depends on disable/enable state for the type.
460 elsif not Is_Atomic
(E
) and then Is_Atomic
(Etype
(E
)) then
461 Set
:= not Atomic_Synchronization_Disabled
(Etype
(E
));
463 -- Else both variable and type are atomic (see outer if), and we
464 -- disable if either variable or its type have sync disabled.
467 Set
:= not Atomic_Synchronization_Disabled
(E
)
469 not Atomic_Synchronization_Disabled
(Etype
(E
));
472 -- Set flag if required
475 Activate_Atomic_Synchronization
(N
);
480 -- Interpret possible Current_Value for variable case. The
481 -- Is_Object_Renaming_Name test is needed for cases such as
483 -- Y : Integer renames Integer'(X);
484 -- where the value of Y is changed by any subsequent assignments to X.
485 -- In cases like this, we do not want to use Current_Value even though
489 and then Present
(Current_Value
(E
))
490 and then not Is_Object_Renaming_Name
(N
)
492 Expand_Current_Value
(N
);
494 -- We do want to warn for the case of a boolean variable (not a
495 -- boolean constant) whose value is known at compile time.
497 if Is_Boolean_Type
(Etype
(N
)) then
498 Warn_On_Known_Condition
(N
);
501 -- Don't mess with Current_Value for compile time known values. Not
502 -- only is it unnecessary, but we could disturb an indication of a
503 -- static value, which could cause semantic trouble.
505 elsif Compile_Time_Known_Value
(N
) then
508 -- Interpret possible Current_Value for constant case
510 elsif Is_Constant_Object
(E
)
511 and then Present
(Current_Value
(E
))
513 Expand_Current_Value
(N
);
515 end Expand_Entity_Reference
;
517 ----------------------------------
518 -- Expand_Entry_Index_Parameter --
519 ----------------------------------
521 procedure Expand_Entry_Index_Parameter
(N
: Node_Id
) is
522 Index_Con
: constant Entity_Id
:= Entry_Index_Constant
(Entity
(N
));
524 Set_Entity
(N
, Index_Con
);
525 Set_Etype
(N
, Etype
(Index_Con
));
526 end Expand_Entry_Index_Parameter
;
528 ----------------------------
529 -- Expand_Entry_Parameter --
530 ----------------------------
532 procedure Expand_Entry_Parameter
(N
: Node_Id
) is
533 Loc
: constant Source_Ptr
:= Sloc
(N
);
534 Ent_Formal
: constant Entity_Id
:= Entity
(N
);
535 Ent_Spec
: constant Entity_Id
:= Scope
(Ent_Formal
);
536 Parm_Type
: constant Entity_Id
:= Entry_Parameters_Type
(Ent_Spec
);
537 Acc_Stack
: constant Elist_Id
:= Accept_Address
(Ent_Spec
);
538 Addr_Ent
: constant Entity_Id
:= Node
(Last_Elmt
(Acc_Stack
));
539 P_Comp_Ref
: Entity_Id
;
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 Known_To_Be_Assigned
(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_Occurrence_Of
(Addr_Ent
, Loc
))),
582 New_Occurrence_Of
(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
639 pragma Unreferenced
(N
);
642 -- Historically, this routine existed because there were expansion
643 -- requirements for Vax real literals, but now Vax real literals
644 -- are now handled by gigi, so this routine no longer does anything.
647 end Expand_N_Real_Literal
;
649 --------------------------------
650 -- Expand_Protected_Component --
651 --------------------------------
653 procedure Expand_Protected_Component
(N
: Node_Id
) is
655 function Inside_Eliminated_Body
return Boolean;
656 -- Determine whether the current entity is inside a subprogram or an
657 -- entry which has been marked as eliminated.
659 ----------------------------
660 -- Inside_Eliminated_Body --
661 ----------------------------
663 function Inside_Eliminated_Body
return Boolean is
664 S
: Entity_Id
:= Current_Scope
;
667 while Present
(S
) loop
668 if (Ekind
(S
) = E_Entry
669 or else Ekind
(S
) = E_Entry_Family
670 or else Ekind
(S
) = E_Function
671 or else Ekind
(S
) = E_Procedure
)
672 and then Is_Eliminated
(S
)
681 end Inside_Eliminated_Body
;
683 -- Start of processing for Expand_Protected_Component
686 -- Eliminated bodies are not expanded and thus do not need privals
688 if not Inside_Eliminated_Body
then
690 Priv
: constant Entity_Id
:= Prival
(Entity
(N
));
692 Set_Entity
(N
, Priv
);
693 Set_Etype
(N
, Etype
(Priv
));
696 end Expand_Protected_Component
;
698 ---------------------
699 -- Expand_Renaming --
700 ---------------------
702 procedure Expand_Renaming
(N
: Node_Id
) is
703 E
: constant Entity_Id
:= Entity
(N
);
704 T
: constant Entity_Id
:= Etype
(N
);
707 Rewrite
(N
, New_Copy_Tree
(Renamed_Object
(E
)));
709 -- We mark the copy as unanalyzed, so that it is sure to be reanalyzed
710 -- at the top level. This is needed in the packed case since we
711 -- specifically avoided expanding packed array references when the
712 -- renaming declaration was analyzed.
714 Reset_Analyzed_Flags
(N
);
715 Analyze_And_Resolve
(N
, T
);
718 ------------------------------------------
719 -- Expand_N_Interpolated_String_Literal --
720 ------------------------------------------
722 procedure Expand_N_Interpolated_String_Literal
(N
: Node_Id
) is
724 function Build_Interpolated_String_Image
(N
: Node_Id
) return Node_Id
;
725 -- Build the following Expression_With_Actions node:
728 -- [ Set_Trim_Leading_Spaces (Sink); ]
729 -- Type'Put_Image (Sink, X);
730 -- { [ Set_Trim_Leading_Spaces (Sink); ]
731 -- Type'Put_Image (Sink, X); }
732 -- Result : constant String := Get (Sink);
736 -------------------------------------
737 -- Build_Interpolated_String_Image --
738 -------------------------------------
740 function Build_Interpolated_String_Image
(N
: Node_Id
) return Node_Id
742 Loc
: constant Source_Ptr
:= Sloc
(N
);
743 Sink_Entity
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
744 Sink_Decl
: constant Node_Id
:=
745 Make_Object_Declaration
(Loc
,
746 Defining_Identifier
=> Sink_Entity
,
748 New_Occurrence_Of
(RTE
(RE_Buffer_Type
), Loc
));
750 Get_Id
: constant RE_Id
:=
751 (if Etype
(N
) = Stand
.Standard_String
then
753 elsif Etype
(N
) = Stand
.Standard_Wide_String
then
758 Result_Entity
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
759 Result_Decl
: constant Node_Id
:=
760 Make_Object_Declaration
(Loc
,
761 Defining_Identifier
=> Result_Entity
,
763 New_Occurrence_Of
(Etype
(N
), Loc
),
765 Make_Function_Call
(Loc
,
766 Name
=> New_Occurrence_Of
(RTE
(Get_Id
), Loc
),
767 Parameter_Associations
=> New_List
(
768 New_Occurrence_Of
(Sink_Entity
, Loc
))));
770 Actions
: constant List_Id
:= New_List
;
771 U_Type
: constant Entity_Id
:= Underlying_Type
(Etype
(N
));
772 Elem_Typ
: Entity_Id
;
776 pragma Assert
(Etype
(N
) /= Stand
.Any_String
);
778 Append_To
(Actions
, Sink_Decl
);
780 Str_Elem
:= First
(Expressions
(N
));
781 while Present
(Str_Elem
) loop
782 Elem_Typ
:= Etype
(Str_Elem
);
784 -- If the type is numeric or has a specified Integer_Literal or
785 -- Real_Literal aspect, then prior to invoking Put_Image, the
786 -- Trim_Leading_Spaces flag is set on the text buffer.
788 if Is_Numeric_Type
(Underlying_Type
(Elem_Typ
))
789 or else Has_Aspect
(Elem_Typ
, Aspect_Integer_Literal
)
790 or else Has_Aspect
(Elem_Typ
, Aspect_Real_Literal
)
793 Make_Procedure_Call_Statement
(Loc
,
796 (RTE
(RE_Set_Trim_Leading_Spaces
), Loc
),
797 Parameter_Associations
=> New_List
(
798 Convert_To
(RTE
(RE_Root_Buffer_Type
),
799 New_Occurrence_Of
(Sink_Entity
, Loc
)),
800 New_Occurrence_Of
(Stand
.Standard_True
, Loc
))));
804 Make_Attribute_Reference
(Loc
,
805 Prefix
=> New_Occurrence_Of
(Elem_Typ
, Loc
),
806 Attribute_Name
=> Name_Put_Image
,
807 Expressions
=> New_List
(
808 New_Occurrence_Of
(Sink_Entity
, Loc
),
809 Duplicate_Subexpr
(Str_Elem
))));
814 -- Add a type conversion to the result object declaration of custom
817 if not Is_Standard_String_Type
(U_Type
)
818 and then (not RTU_Loaded
(Interfaces_C
)
819 or else Enclosing_Lib_Unit_Entity
(U_Type
)
820 /= RTU_Entity
(Interfaces_C
))
822 Set_Expression
(Result_Decl
,
823 Convert_To
(Etype
(N
),
824 Relocate_Node
(Expression
(Result_Decl
))));
827 Append_To
(Actions
, Result_Decl
);
829 return Make_Expression_With_Actions
(Loc
,
831 Expression
=> New_Occurrence_Of
(Result_Entity
, Loc
));
832 end Build_Interpolated_String_Image
;
836 Typ
: constant Entity_Id
:= Etype
(N
);
838 -- Start of processing for Expand_N_Interpolated_String_Literal
841 Rewrite
(N
, Build_Interpolated_String_Image
(N
));
842 Analyze_And_Resolve
(N
, Typ
);
843 end Expand_N_Interpolated_String_Literal
;