1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Exp_Atag
; use Exp_Atag
;
32 with Exp_Ch2
; use Exp_Ch2
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Dist
; use Exp_Dist
;
37 with Exp_Imgv
; use Exp_Imgv
;
38 with Exp_Pakd
; use Exp_Pakd
;
39 with Exp_Strm
; use Exp_Strm
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Freeze
; use Freeze
;
43 with Gnatvsn
; use Gnatvsn
;
44 with Itypes
; use Itypes
;
46 with Namet
; use Namet
;
47 with Nmake
; use Nmake
;
48 with Nlists
; use Nlists
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
54 with Sem_Aux
; use Sem_Aux
;
55 with Sem_Ch6
; use Sem_Ch6
;
56 with Sem_Ch7
; use Sem_Ch7
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Util
; use Sem_Util
;
61 with Sinfo
; use Sinfo
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Stringt
; use Stringt
;
65 with Targparm
; use Targparm
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Uintp
; use Uintp
;
69 with Uname
; use Uname
;
70 with Validsw
; use Validsw
;
72 package body Exp_Attr
is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Build_Array_VS_Func
80 Nod
: Node_Id
) return Entity_Id
;
81 -- Build function to test Valid_Scalars for array type A_Type. Nod is the
82 -- Valid_Scalars attribute node, used to insert the function body, and the
83 -- value returned is the entity of the constructed function body. We do not
84 -- bother to generate a separate spec for this subprogram.
86 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
87 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
89 function Build_Record_VS_Func
91 Nod
: Node_Id
) return Entity_Id
;
92 -- Build function to test Valid_Scalars for record type A_Type. Nod is the
93 -- Valid_Scalars attribute node, used to insert the function body, and the
94 -- value returned is the entity of the constructed function body. We do not
95 -- bother to generate a separate spec for this subprogram.
97 procedure Compile_Stream_Body_In_Scope
102 -- The body for a stream subprogram may be generated outside of the scope
103 -- of the type. If the type is fully private, it may depend on the full
104 -- view of other types (e.g. indexes) that are currently private as well.
105 -- We install the declarations of the package in which the type is declared
106 -- before compiling the body in what is its proper environment. The Check
107 -- parameter indicates if checks are to be suppressed for the stream body.
108 -- We suppress checks for array/record reads, since the rule is that these
109 -- are like assignments, out of range values due to uninitialized storage,
110 -- or other invalid values do NOT cause a Constraint_Error to be raised.
111 -- If we are within an instance body all visibility has been established
112 -- already and there is no need to install the package.
114 -- This mechanism is now extended to the component types of the array type,
115 -- when the component type is not in scope and is private, to handle
116 -- properly the case when the full view has defaulted discriminants.
118 -- This special processing is ultimately caused by the fact that the
119 -- compiler lacks a well-defined phase when full views are visible
120 -- everywhere. Having such a separate pass would remove much of the
121 -- special-case code that shuffles partial and full views in the middle
122 -- of semantic analysis and expansion.
124 procedure Expand_Access_To_Protected_Op
128 -- An attribute reference to a protected subprogram is transformed into
129 -- a pair of pointers: one to the object, and one to the operations.
130 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
132 procedure Expand_Fpt_Attribute
137 -- This procedure expands a call to a floating-point attribute function.
138 -- N is the attribute reference node, and Args is a list of arguments to
139 -- be passed to the function call. Pkg identifies the package containing
140 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
141 -- have already been converted to the floating-point type for which Pkg was
142 -- instantiated. The Nam argument is the relevant attribute processing
143 -- routine to be called. This is the same as the attribute name, except in
144 -- the Unaligned_Valid case.
146 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
147 -- This procedure expands a call to a floating-point attribute function
148 -- that takes a single floating-point argument. The function to be called
149 -- is always the same as the attribute name.
151 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
152 -- This procedure expands a call to a floating-point attribute function
153 -- that takes one floating-point argument and one integer argument. The
154 -- function to be called is always the same as the attribute name.
156 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
157 -- This procedure expands a call to a floating-point attribute function
158 -- that takes two floating-point arguments. The function to be called
159 -- is always the same as the attribute name.
161 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
162 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
163 -- loop may be converted into a conditional block. See body for details.
165 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
166 -- Handle the expansion of attributes 'Max and 'Min, including expanding
167 -- then out if we are in Modify_Tree_For_C mode.
169 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
170 -- Handles expansion of Pred or Succ attributes for case of non-real
171 -- operand with overflow checking required.
173 procedure Expand_Update_Attribute
(N
: Node_Id
);
174 -- Handle the expansion of attribute Update
176 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
177 -- Used for Last, Last, and Length, when the prefix is an array type.
178 -- Obtains the corresponding index subtype.
180 procedure Find_Fat_Info
182 Fat_Type
: out Entity_Id
;
183 Fat_Pkg
: out RE_Id
);
184 -- Given a floating-point type T, identifies the package containing the
185 -- attributes for this type (returned in Fat_Pkg), and the corresponding
186 -- type for which this package was instantiated from Fat_Gen. Error if T
187 -- is not a floating-point type.
189 function Find_Stream_Subprogram
191 Nam
: TSS_Name_Type
) return Entity_Id
;
192 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
193 -- types, the corresponding primitive operation is looked up, else the
194 -- appropriate TSS from the type itself, or from its closest ancestor
195 -- defining it, is returned. In both cases, inheritance of representation
196 -- aspects is thus taken into account.
198 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
199 -- The stream functions need to examine the underlying representation of
200 -- composite types. In some cases T may be non-private but its base type
201 -- is, in which case the function returns the corresponding full view.
203 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
204 -- Given a type, find a corresponding stream convert pragma that applies to
205 -- the implementation base type of this type (Typ). If found, return the
206 -- pragma node, otherwise return Empty if no pragma is found.
208 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
209 -- Utility for array attributes, returns true on packed constrained
210 -- arrays, and on access to same.
212 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
213 -- Returns true iff the given node refers to an attribute call that
214 -- can be expanded directly by the back end and does not need front end
215 -- expansion. Typically used for rounding and truncation attributes that
216 -- appear directly inside a conversion to integer.
218 -------------------------
219 -- Build_Array_VS_Func --
220 -------------------------
222 function Build_Array_VS_Func
224 Nod
: Node_Id
) return Entity_Id
226 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
227 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
228 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
229 Body_Stmts
: List_Id
;
230 Index_List
: List_Id
;
233 function Test_Component
return List_Id
;
234 -- Create one statement to test validity of one component designated by
235 -- a full set of indexes. Returns statement list containing test.
237 function Test_One_Dimension
(N
: Int
) return List_Id
;
238 -- Create loop to test one dimension of the array. The single statement
239 -- in the loop body tests the inner dimensions if any, or else the
240 -- single component. Note that this procedure is called recursively,
241 -- with N being the dimension to be initialized. A call with N greater
242 -- than the number of dimensions simply generates the component test,
243 -- terminating the recursion. Returns statement list containing tests.
249 function Test_Component
return List_Id
is
255 Make_Indexed_Component
(Loc
,
256 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
257 Expressions
=> Index_List
);
259 if Is_Scalar_Type
(Comp_Type
) then
262 Anam
:= Name_Valid_Scalars
;
266 Make_If_Statement
(Loc
,
270 Make_Attribute_Reference
(Loc
,
271 Attribute_Name
=> Anam
,
273 Then_Statements
=> New_List
(
274 Make_Simple_Return_Statement
(Loc
,
275 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
278 ------------------------
279 -- Test_One_Dimension --
280 ------------------------
282 function Test_One_Dimension
(N
: Int
) return List_Id
is
286 -- If all dimensions dealt with, we simply test the component
288 if N
> Number_Dimensions
(A_Type
) then
289 return Test_Component
;
291 -- Here we generate the required loop
295 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
297 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
300 Make_Implicit_Loop_Statement
(Nod
,
303 Make_Iteration_Scheme
(Loc
,
304 Loop_Parameter_Specification
=>
305 Make_Loop_Parameter_Specification
(Loc
,
306 Defining_Identifier
=> Index
,
307 Discrete_Subtype_Definition
=>
308 Make_Attribute_Reference
(Loc
,
309 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
310 Attribute_Name
=> Name_Range
,
311 Expressions
=> New_List
(
312 Make_Integer_Literal
(Loc
, N
))))),
313 Statements
=> Test_One_Dimension
(N
+ 1)),
314 Make_Simple_Return_Statement
(Loc
,
315 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
317 end Test_One_Dimension
;
319 -- Start of processing for Build_Array_VS_Func
322 Index_List
:= New_List
;
323 Body_Stmts
:= Test_One_Dimension
(1);
325 -- Parameter is always (A : A_Typ)
327 Formals
:= New_List
(
328 Make_Parameter_Specification
(Loc
,
329 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uA
),
331 Out_Present
=> False,
332 Parameter_Type
=> New_Occurrence_Of
(A_Type
, Loc
)));
336 Set_Ekind
(Func_Id
, E_Function
);
337 Set_Is_Internal
(Func_Id
);
340 Make_Subprogram_Body
(Loc
,
342 Make_Function_Specification
(Loc
,
343 Defining_Unit_Name
=> Func_Id
,
344 Parameter_Specifications
=> Formals
,
346 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
347 Declarations
=> New_List
,
348 Handled_Statement_Sequence
=>
349 Make_Handled_Sequence_Of_Statements
(Loc
,
350 Statements
=> Body_Stmts
)));
352 if not Debug_Generated_Code
then
353 Set_Debug_Info_Off
(Func_Id
);
356 Set_Is_Pure
(Func_Id
);
358 end Build_Array_VS_Func
;
360 ---------------------------------
361 -- Build_Disp_Get_Task_Id_Call --
362 ---------------------------------
364 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
365 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
366 Typ
: constant Entity_Id
:= Etype
(Actual
);
367 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
371 -- _Disp_Get_Task_Id (Actual)
374 Make_Function_Call
(Loc
,
375 Name
=> New_Occurrence_Of
(Subp
, Loc
),
376 Parameter_Associations
=> New_List
(Actual
));
377 end Build_Disp_Get_Task_Id_Call
;
379 --------------------------
380 -- Build_Record_VS_Func --
381 --------------------------
385 -- function _Valid_Scalars (X : T) return Boolean is
387 -- -- Check discriminants
389 -- if not X.D1'Valid_Scalars or else
390 -- not X.D2'Valid_Scalars or else
396 -- -- Check components
398 -- if not X.C1'Valid_Scalars or else
399 -- not X.C2'Valid_Scalars or else
405 -- -- Check variant part
409 -- if not X.C2'Valid_Scalars or else
410 -- not X.C3'Valid_Scalars or else
417 -- if not X.Cn'Valid_Scalars or else
425 -- end _Valid_Scalars;
427 function Build_Record_VS_Func
429 Nod
: Node_Id
) return Entity_Id
431 Loc
: constant Source_Ptr
:= Sloc
(R_Type
);
432 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
433 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_X
);
435 function Make_VS_Case
438 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
;
439 -- Building block for variant valid scalars. Given a Component_List node
440 -- CL, it generates an 'if' followed by a 'case' statement that compares
441 -- all components of local temporaries named X and Y (that are declared
442 -- as formals at some upper level). E provides the Sloc to be used for
443 -- the generated code.
447 L
: List_Id
) return Node_Id
;
448 -- Building block for variant validate scalars. Given the list, L, of
449 -- components (or discriminants) L, it generates a return statement that
450 -- compares all components of local temporaries named X and Y (that are
451 -- declared as formals at some upper level). E provides the Sloc to be
452 -- used for the generated code.
458 -- <Make_VS_If on shared components>
461 -- when V1 => <Make_VS_Case> on subcomponents
463 -- when Vn => <Make_VS_Case> on subcomponents
466 function Make_VS_Case
469 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
471 Loc
: constant Source_Ptr
:= Sloc
(E
);
472 Result
: constant List_Id
:= New_List
;
477 Append_To
(Result
, Make_VS_If
(E
, Component_Items
(CL
)));
479 if No
(Variant_Part
(CL
)) then
483 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
489 Alt_List
:= New_List
;
490 while Present
(Variant
) loop
492 Make_Case_Statement_Alternative
(Loc
,
493 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
495 Make_VS_Case
(E
, Component_List
(Variant
), Discrs
)));
496 Next_Non_Pragma
(Variant
);
500 Make_Case_Statement
(Loc
,
502 Make_Selected_Component
(Loc
,
503 Prefix
=> Make_Identifier
(Loc
, Name_X
),
504 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
505 Alternatives
=> Alt_List
));
517 -- not X.C1'Valid_Scalars
519 -- not X.C2'Valid_Scalars
525 -- or a null statement if the list L is empty
529 L
: List_Id
) return Node_Id
531 Loc
: constant Source_Ptr
:= Sloc
(E
);
534 Field_Name
: Name_Id
;
539 return Make_Null_Statement
(Loc
);
544 C
:= First_Non_Pragma
(L
);
545 while Present
(C
) loop
546 Def_Id
:= Defining_Identifier
(C
);
547 Field_Name
:= Chars
(Def_Id
);
549 -- The tags need not be checked since they will always be valid
551 -- Note also that in the following, we use Make_Identifier for
552 -- the component names. Use of New_Occurrence_Of to identify
553 -- the components would be incorrect because wrong entities for
554 -- discriminants could be picked up in the private type case.
556 -- Don't bother with abstract parent in interface case
558 if Field_Name
= Name_uParent
559 and then Is_Interface
(Etype
(Def_Id
))
563 -- Don't bother with tag, always valid, and not scalar anyway
565 elsif Field_Name
= Name_uTag
then
568 -- Don't bother with component with no scalar components
570 elsif not Scalar_Part_Present
(Etype
(Def_Id
)) then
573 -- Normal case, generate Valid_Scalars attribute reference
576 Evolve_Or_Else
(Cond
,
579 Make_Attribute_Reference
(Loc
,
581 Make_Selected_Component
(Loc
,
583 Make_Identifier
(Loc
, Name_X
),
585 Make_Identifier
(Loc
, Field_Name
)),
586 Attribute_Name
=> Name_Valid_Scalars
)));
593 return Make_Null_Statement
(Loc
);
597 Make_Implicit_If_Statement
(E
,
599 Then_Statements
=> New_List
(
600 Make_Simple_Return_Statement
(Loc
,
602 New_Occurrence_Of
(Standard_False
, Loc
))));
609 Def
: constant Node_Id
:= Parent
(R_Type
);
610 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
611 Stmts
: constant List_Id
:= New_List
;
612 Pspecs
: constant List_Id
:= New_List
;
614 -- Start of processing for Build_Record_VS_Func
618 Make_Parameter_Specification
(Loc
,
619 Defining_Identifier
=> X
,
620 Parameter_Type
=> New_Occurrence_Of
(R_Type
, Loc
)));
623 Make_VS_If
(R_Type
, Discriminant_Specifications
(Def
)));
624 Append_List_To
(Stmts
, Make_VS_Case
(R_Type
, Comps
));
627 Make_Simple_Return_Statement
(Loc
,
628 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
631 Make_Subprogram_Body
(Loc
,
633 Make_Function_Specification
(Loc
,
634 Defining_Unit_Name
=> Func_Id
,
635 Parameter_Specifications
=> Pspecs
,
636 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
637 Declarations
=> New_List
,
638 Handled_Statement_Sequence
=>
639 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)),
640 Suppress
=> Discriminant_Check
);
642 if not Debug_Generated_Code
then
643 Set_Debug_Info_Off
(Func_Id
);
646 Set_Is_Pure
(Func_Id
);
648 end Build_Record_VS_Func
;
650 ----------------------------------
651 -- Compile_Stream_Body_In_Scope --
652 ----------------------------------
654 procedure Compile_Stream_Body_In_Scope
660 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
661 Curr
: constant Entity_Id
:= Current_Scope
;
662 Install
: Boolean := False;
663 Scop
: Entity_Id
:= Scope
(Arr
);
667 and then not In_Open_Scopes
(Scop
)
668 and then Ekind
(Scop
) = E_Package
673 -- The component type may be private, in which case we install its
674 -- full view to compile the subprogram.
676 -- The component type may be private, in which case we install its
677 -- full view to compile the subprogram. We do not do this if the
678 -- type has a Stream_Convert pragma, which indicates that there are
679 -- special stream-processing operations for that type (for example
680 -- Unbounded_String and its wide varieties).
682 Scop
:= Scope
(C_Type
);
684 if Is_Private_Type
(C_Type
)
685 and then Present
(Full_View
(C_Type
))
686 and then not In_Open_Scopes
(Scop
)
687 and then Ekind
(Scop
) = E_Package
688 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
694 -- If we are within an instance body, then all visibility has been
695 -- established already and there is no need to install the package.
697 if Install
and then not In_Instance_Body
then
699 Install_Visible_Declarations
(Scop
);
700 Install_Private_Declarations
(Scop
);
702 -- The entities in the package are now visible, but the generated
703 -- stream entity must appear in the current scope (usually an
704 -- enclosing stream function) so that itypes all have their proper
713 Insert_Action
(N
, Decl
);
715 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
720 -- Remove extra copy of current scope, and package itself
723 End_Package_Scope
(Scop
);
725 end Compile_Stream_Body_In_Scope
;
727 -----------------------------------
728 -- Expand_Access_To_Protected_Op --
729 -----------------------------------
731 procedure Expand_Access_To_Protected_Op
736 -- The value of the attribute_reference is a record containing two
737 -- fields: an access to the protected object, and an access to the
738 -- subprogram itself. The prefix is a selected component.
740 Loc
: constant Source_Ptr
:= Sloc
(N
);
742 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
745 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
746 Acc
: constant Entity_Id
:=
747 Etype
(Next_Component
(First_Component
(E_T
)));
751 -- Start of processing for Expand_Access_To_Protected_Op
754 -- Within the body of the protected type, the prefix designates a local
755 -- operation, and the object is the first parameter of the corresponding
756 -- protected body of the current enclosing operation.
758 if Is_Entity_Name
(Pref
) then
759 -- All indirect calls are external calls, so must do locking and
760 -- barrier reevaluation, even if the 'Access occurs within the
761 -- protected body. Hence the call to External_Subprogram, as opposed
762 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
763 -- that indirect calls from within the same protected body will
764 -- deadlock, as allowed by RM-9.5.1(8,15,17).
766 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
768 -- Don't traverse the scopes when the attribute occurs within an init
769 -- proc, because we directly use the _init formal of the init proc in
772 Curr
:= Current_Scope
;
773 if not Is_Init_Proc
(Curr
) then
774 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
776 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
777 Curr
:= Scope
(Curr
);
781 -- In case of protected entries the first formal of its Protected_
782 -- Body_Subprogram is the address of the object.
784 if Ekind
(Curr
) = E_Entry
then
788 (Protected_Body_Subprogram
(Curr
)), Loc
);
790 -- If the current scope is an init proc, then use the address of the
791 -- _init formal as the object reference.
793 elsif Is_Init_Proc
(Curr
) then
795 Make_Attribute_Reference
(Loc
,
796 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
797 Attribute_Name
=> Name_Address
);
799 -- In case of protected subprograms the first formal of its
800 -- Protected_Body_Subprogram is the object and we get its address.
804 Make_Attribute_Reference
(Loc
,
808 (Protected_Body_Subprogram
(Curr
)), Loc
),
809 Attribute_Name
=> Name_Address
);
812 -- Case where the prefix is not an entity name. Find the
813 -- version of the protected operation to be called from
814 -- outside the protected object.
820 (Entity
(Selector_Name
(Pref
))), Loc
);
823 Make_Attribute_Reference
(Loc
,
824 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
825 Attribute_Name
=> Name_Address
);
829 Make_Attribute_Reference
(Loc
,
831 Attribute_Name
=> Name_Access
);
833 -- We set the type of the access reference to the already generated
834 -- access_to_subprogram type, and declare the reference analyzed, to
835 -- prevent further expansion when the enclosing aggregate is analyzed.
837 Set_Etype
(Sub_Ref
, Acc
);
838 Set_Analyzed
(Sub_Ref
);
842 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
844 -- Sub_Ref has been marked as analyzed, but we still need to make sure
845 -- Sub is correctly frozen.
847 Freeze_Before
(N
, Entity
(Sub
));
850 Analyze_And_Resolve
(N
, E_T
);
852 -- For subsequent analysis, the node must retain its type. The backend
853 -- will replace it with the equivalent type where needed.
856 end Expand_Access_To_Protected_Op
;
858 --------------------------
859 -- Expand_Fpt_Attribute --
860 --------------------------
862 procedure Expand_Fpt_Attribute
868 Loc
: constant Source_Ptr
:= Sloc
(N
);
869 Typ
: constant Entity_Id
:= Etype
(N
);
873 -- The function name is the selected component Attr_xxx.yyy where
874 -- Attr_xxx is the package name, and yyy is the argument Nam.
876 -- Note: it would be more usual to have separate RE entries for each
877 -- of the entities in the Fat packages, but first they have identical
878 -- names (so we would have to have lots of renaming declarations to
879 -- meet the normal RE rule of separate names for all runtime entities),
880 -- and second there would be an awful lot of them.
883 Make_Selected_Component
(Loc
,
884 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
885 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
887 -- The generated call is given the provided set of parameters, and then
888 -- wrapped in a conversion which converts the result to the target type
889 -- We use the base type as the target because a range check may be
893 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
894 Make_Function_Call
(Loc
,
896 Parameter_Associations
=> Args
)));
898 Analyze_And_Resolve
(N
, Typ
);
899 end Expand_Fpt_Attribute
;
901 ----------------------------
902 -- Expand_Fpt_Attribute_R --
903 ----------------------------
905 -- The single argument is converted to its root type to call the
906 -- appropriate runtime function, with the actual call being built
907 -- by Expand_Fpt_Attribute
909 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
910 E1
: constant Node_Id
:= First
(Expressions
(N
));
914 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
916 (N
, Pkg
, Attribute_Name
(N
),
917 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
918 end Expand_Fpt_Attribute_R
;
920 -----------------------------
921 -- Expand_Fpt_Attribute_RI --
922 -----------------------------
924 -- The first argument is converted to its root type and the second
925 -- argument is converted to standard long long integer to call the
926 -- appropriate runtime function, with the actual call being built
927 -- by Expand_Fpt_Attribute
929 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
930 E1
: constant Node_Id
:= First
(Expressions
(N
));
933 E2
: constant Node_Id
:= Next
(E1
);
935 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
937 (N
, Pkg
, Attribute_Name
(N
),
939 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
940 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
941 end Expand_Fpt_Attribute_RI
;
943 -----------------------------
944 -- Expand_Fpt_Attribute_RR --
945 -----------------------------
947 -- The two arguments are converted to their root types to call the
948 -- appropriate runtime function, with the actual call being built
949 -- by Expand_Fpt_Attribute
951 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
952 E1
: constant Node_Id
:= First
(Expressions
(N
));
953 E2
: constant Node_Id
:= Next
(E1
);
958 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
960 (N
, Pkg
, Attribute_Name
(N
),
962 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
963 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
964 end Expand_Fpt_Attribute_RR
;
966 ---------------------------------
967 -- Expand_Loop_Entry_Attribute --
968 ---------------------------------
970 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
971 procedure Build_Conditional_Block
975 If_Stmt
: out Node_Id
;
976 Blk_Stmt
: out Node_Id
);
977 -- Create a block Blk_Stmt with an empty declarative list and a single
978 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
979 -- condition Cond. If_Stmt is Empty when there is no condition provided.
981 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
982 -- Determine whether loop statement N denotes an Ada 2012 iteration over
985 -----------------------------
986 -- Build_Conditional_Block --
987 -----------------------------
989 procedure Build_Conditional_Block
993 If_Stmt
: out Node_Id
;
994 Blk_Stmt
: out Node_Id
)
997 -- Do not reanalyze the original loop statement because it is simply
1000 Set_Analyzed
(Loop_Stmt
);
1003 Make_Block_Statement
(Loc
,
1004 Declarations
=> New_List
,
1005 Handled_Statement_Sequence
=>
1006 Make_Handled_Sequence_Of_Statements
(Loc
,
1007 Statements
=> New_List
(Loop_Stmt
)));
1009 if Present
(Cond
) then
1011 Make_If_Statement
(Loc
,
1013 Then_Statements
=> New_List
(Blk_Stmt
));
1017 end Build_Conditional_Block
;
1019 ------------------------
1020 -- Is_Array_Iteration --
1021 ------------------------
1023 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1024 Stmt
: constant Node_Id
:= Original_Node
(N
);
1028 if Nkind
(Stmt
) = N_Loop_Statement
1029 and then Present
(Iteration_Scheme
(Stmt
))
1030 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1032 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1035 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1039 end Is_Array_Iteration
;
1043 Pref
: constant Node_Id
:= Prefix
(N
);
1044 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1045 Exprs
: constant List_Id
:= Expressions
(N
);
1049 Installed
: Boolean;
1051 Loop_Id
: Entity_Id
;
1052 Loop_Stmt
: Node_Id
;
1053 Result
: Node_Id
:= Empty
;
1055 Temp_Decl
: Node_Id
;
1056 Temp_Id
: Entity_Id
;
1058 -- Start of processing for Expand_Loop_Entry_Attribute
1061 -- Step 1: Find the related loop
1063 -- The loop label variant of attribute 'Loop_Entry already has all the
1064 -- information in its expression.
1066 if Present
(Exprs
) then
1067 Loop_Id
:= Entity
(First
(Exprs
));
1068 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1070 -- Climb the parent chain to find the nearest enclosing loop. Skip
1071 -- all internally generated loops for quantified expressions and for
1072 -- element iterators over multidimensional arrays because the pragma
1073 -- applies to source loop.
1077 while Present
(Loop_Stmt
) loop
1078 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1079 and then Comes_From_Source
(Loop_Stmt
)
1084 Loop_Stmt
:= Parent
(Loop_Stmt
);
1087 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1090 Loc
:= Sloc
(Loop_Stmt
);
1092 -- Step 2: Transform the loop
1094 -- The loop has already been transformed during the expansion of a prior
1095 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1097 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1099 -- When the related loop name appears as the argument of attribute
1100 -- Loop_Entry, the corresponding label construct is the generated
1101 -- block statement. This is because the expander reuses the label.
1103 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1104 Decls
:= Declarations
(Loop_Stmt
);
1106 -- In all other cases, the loop must appear in the handled sequence
1107 -- of statements of the generated block.
1111 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1113 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1115 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1118 -- Transform the loop into a conditional block
1121 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1122 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1124 -- Infinite loops are transformed into:
1127 -- Temp1 : constant <type of Pref1> := <Pref1>;
1129 -- TempN : constant <type of PrefN> := <PrefN>;
1132 -- <original source statements with attribute rewrites>
1137 Build_Conditional_Block
(Loc
,
1139 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1145 -- While loops are transformed into:
1147 -- function Fnn return Boolean is
1149 -- <condition actions>
1150 -- return <condition>;
1155 -- Temp1 : constant <type of Pref1> := <Pref1>;
1157 -- TempN : constant <type of PrefN> := <PrefN>;
1160 -- <original source statements with attribute rewrites>
1161 -- exit when not Fnn;
1166 -- Note that loops over iterators and containers are already
1167 -- converted into while loops.
1169 elsif Present
(Condition
(Scheme
)) then
1171 Func_Decl
: Node_Id
;
1172 Func_Id
: Entity_Id
;
1176 -- Wrap the condition of the while loop in a Boolean function.
1177 -- This avoids the duplication of the same code which may lead
1178 -- to gigi issues with respect to multiple declaration of the
1179 -- same entity in the presence of side effects or checks. Note
1180 -- that the condition actions must also be relocated to the
1181 -- wrapping function.
1184 -- <condition actions>
1185 -- return <condition>;
1187 if Present
(Condition_Actions
(Scheme
)) then
1188 Stmts
:= Condition_Actions
(Scheme
);
1194 Make_Simple_Return_Statement
(Loc
,
1195 Expression
=> Relocate_Node
(Condition
(Scheme
))));
1198 -- function Fnn return Boolean is
1203 Func_Id
:= Make_Temporary
(Loc
, 'F');
1205 Make_Subprogram_Body
(Loc
,
1207 Make_Function_Specification
(Loc
,
1208 Defining_Unit_Name
=> Func_Id
,
1209 Result_Definition
=>
1210 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1211 Declarations
=> Empty_List
,
1212 Handled_Statement_Sequence
=>
1213 Make_Handled_Sequence_Of_Statements
(Loc
,
1214 Statements
=> Stmts
));
1216 -- The function is inserted before the related loop. Make sure
1217 -- to analyze it in the context of the loop's enclosing scope.
1219 Push_Scope
(Scope
(Loop_Id
));
1220 Insert_Action
(Loop_Stmt
, Func_Decl
);
1223 -- Transform the original while loop into an infinite loop
1224 -- where the last statement checks the negated condition. This
1225 -- placement ensures that the condition will not be evaluated
1226 -- twice on the first iteration.
1228 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1232 -- exit when not Fnn;
1234 Append_To
(Statements
(Loop_Stmt
),
1235 Make_Exit_Statement
(Loc
,
1239 Make_Function_Call
(Loc
,
1240 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1242 Build_Conditional_Block
(Loc
,
1244 Make_Function_Call
(Loc
,
1245 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1246 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1251 -- Ada 2012 iteration over an array is transformed into:
1253 -- if <Array_Nam>'Length (1) > 0
1254 -- and then <Array_Nam>'Length (N) > 0
1257 -- Temp1 : constant <type of Pref1> := <Pref1>;
1259 -- TempN : constant <type of PrefN> := <PrefN>;
1261 -- for X in ... loop -- multiple loops depending on dims
1262 -- <original source statements with attribute rewrites>
1267 elsif Is_Array_Iteration
(Loop_Stmt
) then
1269 Array_Nam
: constant Entity_Id
:=
1270 Entity
(Name
(Iterator_Specification
1271 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1272 Num_Dims
: constant Pos
:=
1273 Number_Dimensions
(Etype
(Array_Nam
));
1274 Cond
: Node_Id
:= Empty
;
1278 -- Generate a check which determines whether all dimensions of
1279 -- the array are non-null.
1281 for Dim
in 1 .. Num_Dims
loop
1285 Make_Attribute_Reference
(Loc
,
1286 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1287 Attribute_Name
=> Name_Length
,
1288 Expressions
=> New_List
(
1289 Make_Integer_Literal
(Loc
, Dim
))),
1291 Make_Integer_Literal
(Loc
, 0));
1299 Right_Opnd
=> Check
);
1303 Build_Conditional_Block
(Loc
,
1305 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1310 -- For loops are transformed into:
1312 -- if <Low> <= <High> then
1314 -- Temp1 : constant <type of Pref1> := <Pref1>;
1316 -- TempN : constant <type of PrefN> := <PrefN>;
1318 -- for <Def_Id> in <Low> .. <High> loop
1319 -- <original source statements with attribute rewrites>
1324 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1326 Loop_Spec
: constant Node_Id
:=
1327 Loop_Parameter_Specification
(Scheme
);
1332 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1334 -- When the loop iterates over a subtype indication with a
1335 -- range, use the low and high bounds of the subtype itself.
1337 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1338 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1341 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1348 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1349 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1351 Build_Conditional_Block
(Loc
,
1353 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1359 Decls
:= Declarations
(Blk
);
1362 -- Step 3: Create a constant to capture the value of the prefix at the
1363 -- entry point into the loop.
1365 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1367 -- Preserve the tag of the prefix by offering a specific view of the
1368 -- class-wide version of the prefix.
1370 if Is_Tagged_Type
(Base_Typ
) then
1371 Tagged_Case
: declare
1372 CW_Temp
: Entity_Id
;
1377 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1379 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1380 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1383 Make_Object_Declaration
(Loc
,
1384 Defining_Identifier
=> CW_Temp
,
1385 Constant_Present
=> True,
1386 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1388 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1389 Append_To
(Decls
, Aux_Decl
);
1392 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1395 Make_Object_Renaming_Declaration
(Loc
,
1396 Defining_Identifier
=> Temp_Id
,
1397 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1399 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1400 Append_To
(Decls
, Temp_Decl
);
1406 Untagged_Case
: declare
1407 Temp_Expr
: Node_Id
;
1412 -- Generate a nominal type for the constant when the prefix is of
1413 -- a constrained type. This is achieved by setting the Etype of
1414 -- the relocated prefix to its base type. Since the prefix is now
1415 -- the initialization expression of the constant, its freezing
1416 -- will produce a proper nominal type.
1418 Temp_Expr
:= Relocate_Node
(Pref
);
1419 Set_Etype
(Temp_Expr
, Base_Typ
);
1422 -- Temp : constant Base_Typ := Pref;
1425 Make_Object_Declaration
(Loc
,
1426 Defining_Identifier
=> Temp_Id
,
1427 Constant_Present
=> True,
1428 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1429 Expression
=> Temp_Expr
);
1430 Append_To
(Decls
, Temp_Decl
);
1434 -- Step 4: Analyze all bits
1436 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1438 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1439 -- associated loop, ensure the proper visibility for analysis.
1441 if not Installed
then
1442 Push_Scope
(Scope
(Loop_Id
));
1445 -- The analysis of the conditional block takes care of the constant
1448 if Present
(Result
) then
1449 Rewrite
(Loop_Stmt
, Result
);
1450 Analyze
(Loop_Stmt
);
1452 -- The conditional block was analyzed when a previous 'Loop_Entry was
1453 -- expanded. There is no point in reanalyzing the block, simply analyze
1454 -- the declaration of the constant.
1457 if Present
(Aux_Decl
) then
1461 Analyze
(Temp_Decl
);
1464 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1467 if not Installed
then
1470 end Expand_Loop_Entry_Attribute
;
1472 ------------------------------
1473 -- Expand_Min_Max_Attribute --
1474 ------------------------------
1476 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1478 -- Min and Max are handled by the back end (except that static cases
1479 -- have already been evaluated during semantic processing, although the
1480 -- back end should not count on this). The one bit of special processing
1481 -- required in the normal case is that these two attributes typically
1482 -- generate conditionals in the code, so check the relevant restriction.
1484 Check_Restriction
(No_Implicit_Conditionals
, N
);
1486 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1488 if Modify_Tree_For_C
then
1490 Loc
: constant Source_Ptr
:= Sloc
(N
);
1491 Typ
: constant Entity_Id
:= Etype
(N
);
1492 Expr
: constant Node_Id
:= First
(Expressions
(N
));
1493 Left
: constant Node_Id
:= Relocate_Node
(Expr
);
1494 Right
: constant Node_Id
:= Relocate_Node
(Next
(Expr
));
1496 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
;
1497 -- Returns Left >= Right for Max, Left <= Right for Min
1503 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
is
1505 if Attribute_Name
(N
) = Name_Max
then
1509 Right_Opnd
=> Right
);
1514 Right_Opnd
=> Right
);
1518 -- Start of processing for Min_Max
1521 -- If both Left and Right are side effect free, then we can just
1522 -- use Duplicate_Expr to duplicate the references and return
1524 -- (if Left >=|<= Right then Left else Right)
1526 if Side_Effect_Free
(Left
) and then Side_Effect_Free
(Right
) then
1528 Make_If_Expression
(Loc
,
1529 Expressions
=> New_List
(
1530 Make_Compare
(Left
, Right
),
1531 Duplicate_Subexpr_No_Checks
(Left
),
1532 Duplicate_Subexpr_No_Checks
(Right
))));
1534 -- Otherwise we generate declarations to capture the values.
1536 -- The translation is
1539 -- T1 : constant typ := Left;
1540 -- T2 : constant typ := Right;
1542 -- (if T1 >=|<= T2 then T1 else T2)
1547 T1
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1548 T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Right
);
1552 Make_Expression_With_Actions
(Loc
,
1553 Actions
=> New_List
(
1554 Make_Object_Declaration
(Loc
,
1555 Defining_Identifier
=> T1
,
1556 Constant_Present
=> True,
1557 Object_Definition
=>
1558 New_Occurrence_Of
(Etype
(Left
), Loc
),
1559 Expression
=> Relocate_Node
(Left
)),
1561 Make_Object_Declaration
(Loc
,
1562 Defining_Identifier
=> T2
,
1563 Constant_Present
=> True,
1564 Object_Definition
=>
1565 New_Occurrence_Of
(Etype
(Right
), Loc
),
1566 Expression
=> Relocate_Node
(Right
))),
1569 Make_If_Expression
(Loc
,
1570 Expressions
=> New_List
(
1572 (New_Occurrence_Of
(T1
, Loc
),
1573 New_Occurrence_Of
(T2
, Loc
)),
1574 New_Occurrence_Of
(T1
, Loc
),
1575 New_Occurrence_Of
(T2
, Loc
)))));
1579 Analyze_And_Resolve
(N
, Typ
);
1582 end Expand_Min_Max_Attribute
;
1584 ----------------------------------
1585 -- Expand_N_Attribute_Reference --
1586 ----------------------------------
1588 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1589 Loc
: constant Source_Ptr
:= Sloc
(N
);
1590 Typ
: constant Entity_Id
:= Etype
(N
);
1591 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1592 Pref
: constant Node_Id
:= Prefix
(N
);
1593 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1594 Exprs
: constant List_Id
:= Expressions
(N
);
1595 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1597 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1598 -- Rewrites a stream attribute for Read, Write or Output with the
1599 -- procedure call. Pname is the entity for the procedure to call.
1601 ------------------------------
1602 -- Rewrite_Stream_Proc_Call --
1603 ------------------------------
1605 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1606 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1607 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1608 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1609 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1610 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1613 -- The expansion depends on Item, the second actual, which is
1614 -- the object being streamed in or out.
1616 -- If the item is a component of a packed array type, and
1617 -- a conversion is needed on exit, we introduce a temporary to
1618 -- hold the value, because otherwise the packed reference will
1619 -- not be properly expanded.
1621 if Nkind
(Item
) = N_Indexed_Component
1622 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1623 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1627 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1633 Make_Object_Declaration
(Loc
,
1634 Defining_Identifier
=> Temp
,
1635 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1636 Set_Etype
(Temp
, Formal_Typ
);
1639 Make_Assignment_Statement
(Loc
,
1640 Name
=> New_Copy_Tree
(Item
),
1642 Unchecked_Convert_To
1643 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1645 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1649 Make_Procedure_Call_Statement
(Loc
,
1650 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1651 Parameter_Associations
=> Exprs
),
1654 Rewrite
(N
, Make_Null_Statement
(Loc
));
1659 -- For the class-wide dispatching cases, and for cases in which
1660 -- the base type of the second argument matches the base type of
1661 -- the corresponding formal parameter (that is to say the stream
1662 -- operation is not inherited), we are all set, and can use the
1663 -- argument unchanged.
1665 if not Is_Class_Wide_Type
(Entity
(Pref
))
1666 and then not Is_Class_Wide_Type
(Etype
(Item
))
1667 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1669 -- Perform a view conversion when either the argument or the
1670 -- formal parameter are of a private type.
1672 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1673 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1676 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1678 -- Otherwise perform a regular type conversion to ensure that all
1679 -- relevant checks are installed.
1682 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1685 -- For untagged derived types set Assignment_OK, to prevent
1686 -- copies from being created when the unchecked conversion
1687 -- is expanded (which would happen in Remove_Side_Effects
1688 -- if Expand_N_Unchecked_Conversion were allowed to call
1689 -- Force_Evaluation). The copy could violate Ada semantics in
1690 -- cases such as an actual that is an out parameter. Note that
1691 -- this approach is also used in exp_ch7 for calls to controlled
1692 -- type operations to prevent problems with actuals wrapped in
1693 -- unchecked conversions.
1695 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1696 Set_Assignment_OK
(Item
);
1700 -- The stream operation to call may be a renaming created by an
1701 -- attribute definition clause, and may not be frozen yet. Ensure
1702 -- that it has the necessary extra formals.
1704 if not Is_Frozen
(Pname
) then
1705 Create_Extra_Formals
(Pname
);
1708 -- And now rewrite the call
1711 Make_Procedure_Call_Statement
(Loc
,
1712 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1713 Parameter_Associations
=> Exprs
));
1716 end Rewrite_Stream_Proc_Call
;
1718 -- Start of processing for Expand_N_Attribute_Reference
1721 -- Do required validity checking, if enabled. Do not apply check to
1722 -- output parameters of an Asm instruction, since the value of this
1723 -- is not set till after the attribute has been elaborated, and do
1724 -- not apply the check to the arguments of a 'Read or 'Input attribute
1725 -- reference since the scalar argument is an OUT scalar.
1727 if Validity_Checks_On
and then Validity_Check_Operands
1728 and then Id
/= Attribute_Asm_Output
1729 and then Id
/= Attribute_Read
1730 and then Id
/= Attribute_Input
1735 Expr
:= First
(Expressions
(N
));
1736 while Present
(Expr
) loop
1737 Ensure_Valid
(Expr
);
1743 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1744 -- place function, then a temporary return object needs to be created
1745 -- and access to it must be passed to the function. Currently we limit
1746 -- such functions to those with inherently limited result subtypes, but
1747 -- eventually we plan to expand the functions that are treated as
1748 -- build-in-place to include other composite result types.
1750 if Ada_Version
>= Ada_2005
1751 and then Is_Build_In_Place_Function_Call
(Pref
)
1753 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1756 -- If prefix is a protected type name, this is a reference to the
1757 -- current instance of the type. For a component definition, nothing
1758 -- to do (expansion will occur in the init proc). In other contexts,
1759 -- rewrite into reference to current instance.
1761 if Is_Protected_Self_Reference
(Pref
)
1763 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1764 N_Discriminant_Association
)
1765 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1766 N_Component_Definition
)
1768 -- No action needed for these attributes since the current instance
1769 -- will be rewritten to be the name of the _object parameter
1770 -- associated with the enclosing protected subprogram (see below).
1772 and then Id
/= Attribute_Access
1773 and then Id
/= Attribute_Unchecked_Access
1774 and then Id
/= Attribute_Unrestricted_Access
1776 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1780 -- Remaining processing depends on specific attribute
1782 -- Note: individual sections of the following case statement are
1783 -- allowed to assume there is no code after the case statement, and
1784 -- are legitimately allowed to execute return statements if they have
1785 -- nothing more to do.
1789 -- Attributes related to Ada 2012 iterators
1791 when Attribute_Constant_Indexing
1792 | Attribute_Default_Iterator
1793 | Attribute_Implicit_Dereference
1794 | Attribute_Iterable
1795 | Attribute_Iterator_Element
1796 | Attribute_Variable_Indexing
1800 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1801 -- were already rejected by the parser. Thus they shouldn't appear here.
1803 when Internal_Attribute_Id
=>
1804 raise Program_Error
;
1810 when Attribute_Access
1811 | Attribute_Unchecked_Access
1812 | Attribute_Unrestricted_Access
1814 Access_Cases
: declare
1815 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1816 Btyp_DDT
: Entity_Id
;
1818 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1819 -- If N denotes a compound name (selected component, indexed
1820 -- component, or slice), returns the name of the outermost such
1821 -- enclosing object. Otherwise returns N. If the object is a
1822 -- renaming, then the renamed object is returned.
1824 ----------------------
1825 -- Enclosing_Object --
1826 ----------------------
1828 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1833 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1834 N_Indexed_Component
,
1837 Obj_Name
:= Prefix
(Obj_Name
);
1840 return Get_Referenced_Object
(Obj_Name
);
1841 end Enclosing_Object
;
1843 -- Local declarations
1845 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1847 -- Start of processing for Access_Cases
1850 Btyp_DDT
:= Designated_Type
(Btyp
);
1852 -- Handle designated types that come from the limited view
1854 if From_Limited_With
(Btyp_DDT
)
1855 and then Has_Non_Limited_View
(Btyp_DDT
)
1857 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
1860 -- In order to improve the text of error messages, the designated
1861 -- type of access-to-subprogram itypes is set by the semantics as
1862 -- the associated subprogram entity (see sem_attr). Now we replace
1863 -- such node with the proper E_Subprogram_Type itype.
1865 if Id
= Attribute_Unrestricted_Access
1866 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
1868 -- The following conditions ensure that this special management
1869 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1870 -- At this stage other cases in which the designated type is
1871 -- still a subprogram (instead of an E_Subprogram_Type) are
1872 -- wrong because the semantics must have overridden the type of
1873 -- the node with the type imposed by the context.
1875 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
1876 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
1878 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
1882 Subp
: constant Entity_Id
:=
1883 Directly_Designated_Type
(Typ
);
1885 Extra
: Entity_Id
:= Empty
;
1886 New_Formal
: Entity_Id
;
1887 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1888 Subp_Typ
: Entity_Id
;
1891 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
1892 Set_Etype
(Subp_Typ
, Etype
(Subp
));
1893 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1895 if Present
(Old_Formal
) then
1896 New_Formal
:= New_Copy
(Old_Formal
);
1897 Set_First_Entity
(Subp_Typ
, New_Formal
);
1900 Set_Scope
(New_Formal
, Subp_Typ
);
1901 Etyp
:= Etype
(New_Formal
);
1903 -- Handle itypes. There is no need to duplicate
1904 -- here the itypes associated with record types
1905 -- (i.e the implicit full view of private types).
1908 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
1910 Extra
:= New_Copy
(Etyp
);
1911 Set_Parent
(Extra
, New_Formal
);
1912 Set_Etype
(New_Formal
, Extra
);
1913 Set_Scope
(Extra
, Subp_Typ
);
1916 Extra
:= New_Formal
;
1917 Next_Formal
(Old_Formal
);
1918 exit when No
(Old_Formal
);
1920 Set_Next_Entity
(New_Formal
,
1921 New_Copy
(Old_Formal
));
1922 Next_Entity
(New_Formal
);
1925 Set_Next_Entity
(New_Formal
, Empty
);
1926 Set_Last_Entity
(Subp_Typ
, Extra
);
1929 -- Now that the explicit formals have been duplicated,
1930 -- any extra formals needed by the subprogram must be
1933 if Present
(Extra
) then
1934 Set_Extra_Formal
(Extra
, Empty
);
1937 Create_Extra_Formals
(Subp_Typ
);
1938 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
1943 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
1944 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
1946 -- If prefix is a type name, this is a reference to the current
1947 -- instance of the type, within its initialization procedure.
1949 elsif Is_Entity_Name
(Pref
)
1950 and then Is_Type
(Entity
(Pref
))
1957 -- If the current instance name denotes a task type, then
1958 -- the access attribute is rewritten to be the name of the
1959 -- "_task" parameter associated with the task type's task
1960 -- procedure. An unchecked conversion is applied to ensure
1961 -- a type match in cases of expander-generated calls (e.g.
1964 if Is_Task_Type
(Entity
(Pref
)) then
1966 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
1967 while Present
(Formal
) loop
1968 exit when Chars
(Formal
) = Name_uTask
;
1969 Next_Entity
(Formal
);
1972 pragma Assert
(Present
(Formal
));
1975 Unchecked_Convert_To
(Typ
,
1976 New_Occurrence_Of
(Formal
, Loc
)));
1979 elsif Is_Protected_Type
(Entity
(Pref
)) then
1981 -- No action needed for current instance located in a
1982 -- component definition (expansion will occur in the
1985 if Is_Protected_Type
(Current_Scope
) then
1988 -- If the current instance reference is located in a
1989 -- protected subprogram or entry then rewrite the access
1990 -- attribute to be the name of the "_object" parameter.
1991 -- An unchecked conversion is applied to ensure a type
1992 -- match in cases of expander-generated calls (e.g. init
1995 -- The code may be nested in a block, so find enclosing
1996 -- scope that is a protected operation.
2003 Subp
:= Current_Scope
;
2004 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
2005 Subp
:= Scope
(Subp
);
2010 (Protected_Body_Subprogram
(Subp
));
2012 -- For a protected subprogram the _Object parameter
2013 -- is the protected record, so we create an access
2014 -- to it. The _Object parameter of an entry is an
2017 if Ekind
(Subp
) = E_Entry
then
2019 Unchecked_Convert_To
(Typ
,
2020 New_Occurrence_Of
(Formal
, Loc
)));
2025 Unchecked_Convert_To
(Typ
,
2026 Make_Attribute_Reference
(Loc
,
2027 Attribute_Name
=> Name_Unrestricted_Access
,
2029 New_Occurrence_Of
(Formal
, Loc
))));
2030 Analyze_And_Resolve
(N
);
2035 -- The expression must appear in a default expression,
2036 -- (which in the initialization procedure is the right-hand
2037 -- side of an assignment), and not in a discriminant
2042 while Present
(Par
) loop
2043 exit when Nkind
(Par
) = N_Assignment_Statement
;
2045 if Nkind
(Par
) = N_Component_Declaration
then
2049 Par
:= Parent
(Par
);
2052 if Present
(Par
) then
2054 Make_Attribute_Reference
(Loc
,
2055 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2056 Attribute_Name
=> Attribute_Name
(N
)));
2058 Analyze_And_Resolve
(N
, Typ
);
2063 -- If the prefix of an Access attribute is a dereference of an
2064 -- access parameter (or a renaming of such a dereference, or a
2065 -- subcomponent of such a dereference) and the context is a
2066 -- general access type (including the type of an object or
2067 -- component with an access_definition, but not the anonymous
2068 -- type of an access parameter or access discriminant), then
2069 -- apply an accessibility check to the access parameter. We used
2070 -- to rewrite the access parameter as a type conversion, but that
2071 -- could only be done if the immediate prefix of the Access
2072 -- attribute was the dereference, and didn't handle cases where
2073 -- the attribute is applied to a subcomponent of the dereference,
2074 -- since there's generally no available, appropriate access type
2075 -- to convert to in that case. The attribute is passed as the
2076 -- point to insert the check, because the access parameter may
2077 -- come from a renaming, possibly in a different scope, and the
2078 -- check must be associated with the attribute itself.
2080 elsif Id
= Attribute_Access
2081 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2082 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2083 and then (Ekind
(Btyp
) = E_General_Access_Type
2084 or else Is_Local_Anonymous_Access
(Btyp
))
2085 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
2086 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2087 = E_Anonymous_Access_Type
2088 and then Present
(Extra_Accessibility
2089 (Entity
(Prefix
(Enc_Object
))))
2091 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2093 -- Ada 2005 (AI-251): If the designated type is an interface we
2094 -- add an implicit conversion to force the displacement of the
2095 -- pointer to reference the secondary dispatch table.
2097 elsif Is_Interface
(Btyp_DDT
)
2098 and then (Comes_From_Source
(N
)
2099 or else Comes_From_Source
(Ref_Object
)
2100 or else (Nkind
(Ref_Object
) in N_Has_Chars
2101 and then Chars
(Ref_Object
) = Name_uInit
))
2103 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2105 -- No implicit conversion required if types match, or if
2106 -- the prefix is the class_wide_type of the interface. In
2107 -- either case passing an object of the interface type has
2108 -- already set the pointer correctly.
2110 if Btyp_DDT
= Etype
(Ref_Object
)
2111 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2113 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2118 Rewrite
(Prefix
(N
),
2119 Convert_To
(Btyp_DDT
,
2120 New_Copy_Tree
(Prefix
(N
))));
2122 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2125 -- When the object is an explicit dereference, convert the
2126 -- dereference's prefix.
2130 Obj_DDT
: constant Entity_Id
:=
2132 (Directly_Designated_Type
2133 (Etype
(Prefix
(Ref_Object
))));
2135 -- No implicit conversion required if designated types
2138 if Obj_DDT
/= Btyp_DDT
2139 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2140 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2144 New_Copy_Tree
(Prefix
(Ref_Object
))));
2145 Analyze_And_Resolve
(N
, Typ
);
2156 -- Transforms 'Adjacent into a call to the floating-point attribute
2157 -- function Adjacent in Fat_xxx (where xxx is the root type)
2159 when Attribute_Adjacent
=>
2160 Expand_Fpt_Attribute_RR
(N
);
2166 when Attribute_Address
=> Address
: declare
2167 Task_Proc
: Entity_Id
;
2170 -- If the prefix is a task or a task type, the useful address is that
2171 -- of the procedure for the task body, i.e. the actual program unit.
2172 -- We replace the original entity with that of the procedure.
2174 if Is_Entity_Name
(Pref
)
2175 and then Is_Task_Type
(Entity
(Pref
))
2177 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2179 while Present
(Task_Proc
) loop
2180 exit when Ekind
(Task_Proc
) = E_Procedure
2181 and then Etype
(First_Formal
(Task_Proc
)) =
2182 Corresponding_Record_Type
(Ptyp
);
2183 Next_Entity
(Task_Proc
);
2186 if Present
(Task_Proc
) then
2187 Set_Entity
(Pref
, Task_Proc
);
2188 Set_Etype
(Pref
, Etype
(Task_Proc
));
2191 -- Similarly, the address of a protected operation is the address
2192 -- of the corresponding protected body, regardless of the protected
2193 -- object from which it is selected.
2195 elsif Nkind
(Pref
) = N_Selected_Component
2196 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2197 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2201 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2203 elsif Nkind
(Pref
) = N_Explicit_Dereference
2204 and then Ekind
(Ptyp
) = E_Subprogram_Type
2205 and then Convention
(Ptyp
) = Convention_Protected
2207 -- The prefix is be a dereference of an access_to_protected_
2208 -- subprogram. The desired address is the second component of
2209 -- the record that represents the access.
2212 Addr
: constant Entity_Id
:= Etype
(N
);
2213 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2214 T
: constant Entity_Id
:=
2215 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2219 Unchecked_Convert_To
(Addr
,
2220 Make_Selected_Component
(Loc
,
2221 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2222 Selector_Name
=> New_Occurrence_Of
(
2223 Next_Entity
(First_Entity
(T
)), Loc
))));
2225 Analyze_And_Resolve
(N
, Addr
);
2228 -- Ada 2005 (AI-251): Class-wide interface objects are always
2229 -- "displaced" to reference the tag associated with the interface
2230 -- type. In order to obtain the real address of such objects we
2231 -- generate a call to a run-time subprogram that returns the base
2232 -- address of the object.
2234 -- This processing is not needed in the VM case, where dispatching
2235 -- issues are taken care of by the virtual machine.
2237 elsif Is_Class_Wide_Type
(Ptyp
)
2238 and then Is_Interface
(Ptyp
)
2239 and then Tagged_Type_Expansion
2240 and then not (Nkind
(Pref
) in N_Has_Entity
2241 and then Is_Subprogram
(Entity
(Pref
)))
2244 Make_Function_Call
(Loc
,
2245 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2246 Parameter_Associations
=> New_List
(
2247 Relocate_Node
(N
))));
2252 -- Deal with packed array reference, other cases are handled by
2255 if Involves_Packed_Array_Reference
(Pref
) then
2256 Expand_Packed_Address_Reference
(N
);
2264 when Attribute_Alignment
=> Alignment
: declare
2268 -- For class-wide types, X'Class'Alignment is transformed into a
2269 -- direct reference to the Alignment of the class type, so that the
2270 -- back end does not have to deal with the X'Class'Alignment
2273 if Is_Entity_Name
(Pref
)
2274 and then Is_Class_Wide_Type
(Entity
(Pref
))
2276 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2279 -- For x'Alignment applied to an object of a class wide type,
2280 -- transform X'Alignment into a call to the predefined primitive
2281 -- operation _Alignment applied to X.
2283 elsif Is_Class_Wide_Type
(Ptyp
) then
2285 Make_Attribute_Reference
(Loc
,
2287 Attribute_Name
=> Name_Tag
);
2289 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2291 -- Case where the context is a specific integer type with which
2292 -- the original attribute was compatible. The function has a
2293 -- specific type as well, so to preserve the compatibility we
2294 -- must convert explicitly.
2296 if Typ
/= Standard_Integer
then
2297 New_Node
:= Convert_To
(Typ
, New_Node
);
2300 Rewrite
(N
, New_Node
);
2301 Analyze_And_Resolve
(N
, Typ
);
2304 -- For all other cases, we just have to deal with the case of
2305 -- the fact that the result can be universal.
2308 Apply_Universal_Integer_Attribute_Checks
(N
);
2316 -- We compute this if a packed array reference was present, otherwise we
2317 -- leave the computation up to the back end.
2319 when Attribute_Bit
=>
2320 if Involves_Packed_Array_Reference
(Pref
) then
2321 Expand_Packed_Bit_Reference
(N
);
2323 Apply_Universal_Integer_Attribute_Checks
(N
);
2330 -- We compute this if a component clause was present, otherwise we leave
2331 -- the computation up to the back end, since we don't know what layout
2334 -- Note that the attribute can apply to a naked record component
2335 -- in generated code (i.e. the prefix is an identifier that
2336 -- references the component or discriminant entity).
2338 when Attribute_Bit_Position
=> Bit_Position
: declare
2342 if Nkind
(Pref
) = N_Identifier
then
2343 CE
:= Entity
(Pref
);
2345 CE
:= Entity
(Selector_Name
(Pref
));
2348 if Known_Static_Component_Bit_Offset
(CE
) then
2350 Make_Integer_Literal
(Loc
,
2351 Intval
=> Component_Bit_Offset
(CE
)));
2352 Analyze_And_Resolve
(N
, Typ
);
2355 Apply_Universal_Integer_Attribute_Checks
(N
);
2363 -- A reference to P'Body_Version or P'Version is expanded to
2366 -- pragma Import (C, Vnn, "uuuuT");
2368 -- Get_Version_String (Vnn)
2370 -- where uuuu is the unit name (dots replaced by double underscore)
2371 -- and T is B for the cases of Body_Version, or Version applied to a
2372 -- subprogram acting as its own spec, and S for Version applied to a
2373 -- subprogram spec or package. This sequence of code references the
2374 -- unsigned constant created in the main program by the binder.
2376 -- A special exception occurs for Standard, where the string returned
2377 -- is a copy of the library string in gnatvsn.ads.
2379 when Attribute_Body_Version
2383 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2388 -- If not library unit, get to containing library unit
2390 Pent
:= Entity
(Pref
);
2391 while Pent
/= Standard_Standard
2392 and then Scope
(Pent
) /= Standard_Standard
2393 and then not Is_Child_Unit
(Pent
)
2395 Pent
:= Scope
(Pent
);
2398 -- Special case Standard and Standard.ASCII
2400 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2402 Make_String_Literal
(Loc
,
2403 Strval
=> Verbose_Library_Version
));
2408 -- Build required string constant
2410 Get_Name_String
(Get_Unit_Name
(Pent
));
2413 for J
in 1 .. Name_Len
- 2 loop
2414 if Name_Buffer
(J
) = '.' then
2415 Store_String_Chars
("__");
2417 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2421 -- Case of subprogram acting as its own spec, always use body
2423 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2424 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2426 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2428 Store_String_Chars
("B");
2430 -- Case of no body present, always use spec
2432 elsif not Unit_Requires_Body
(Pent
) then
2433 Store_String_Chars
("S");
2435 -- Otherwise use B for Body_Version, S for spec
2437 elsif Id
= Attribute_Body_Version
then
2438 Store_String_Chars
("B");
2440 Store_String_Chars
("S");
2444 Lib
.Version_Referenced
(S
);
2446 -- Insert the object declaration
2448 Insert_Actions
(N
, New_List
(
2449 Make_Object_Declaration
(Loc
,
2450 Defining_Identifier
=> E
,
2451 Object_Definition
=>
2452 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2454 -- Set entity as imported with correct external name
2456 Set_Is_Imported
(E
);
2457 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2459 -- Set entity as internal to ensure proper Sprint output of its
2460 -- implicit importation.
2462 Set_Is_Internal
(E
);
2464 -- And now rewrite original reference
2467 Make_Function_Call
(Loc
,
2469 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2470 Parameter_Associations
=> New_List
(
2471 New_Occurrence_Of
(E
, Loc
))));
2474 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2481 -- Transforms 'Ceiling into a call to the floating-point attribute
2482 -- function Ceiling in Fat_xxx (where xxx is the root type)
2484 when Attribute_Ceiling
=>
2485 Expand_Fpt_Attribute_R
(N
);
2491 -- Transforms 'Callable attribute into a call to the Callable function
2493 when Attribute_Callable
=>
2495 -- We have an object of a task interface class-wide type as a prefix
2496 -- to Callable. Generate:
2497 -- callable (Task_Id (Pref._disp_get_task_id));
2499 if Ada_Version
>= Ada_2005
2500 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2501 and then Is_Interface
(Ptyp
)
2502 and then Is_Task_Interface
(Ptyp
)
2505 Make_Function_Call
(Loc
,
2507 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2508 Parameter_Associations
=> New_List
(
2509 Make_Unchecked_Type_Conversion
(Loc
,
2511 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2512 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
2515 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2518 Analyze_And_Resolve
(N
, Standard_Boolean
);
2524 -- Transforms 'Caller attribute into a call to either the
2525 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2527 when Attribute_Caller
=> Caller
: declare
2528 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2529 Ent
: constant Entity_Id
:= Entity
(Pref
);
2530 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2531 Nest_Depth
: Integer := 0;
2538 if Is_Protected_Type
(Conctype
) then
2539 case Corresponding_Runtime_Package
(Conctype
) is
2540 when System_Tasking_Protected_Objects_Entries
=>
2543 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2545 when System_Tasking_Protected_Objects_Single_Entry
=>
2548 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2551 raise Program_Error
;
2555 Unchecked_Convert_To
(Id_Kind
,
2556 Make_Function_Call
(Loc
,
2558 Parameter_Associations
=> New_List
(
2560 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2565 -- Determine the nesting depth of the E'Caller attribute, that
2566 -- is, how many accept statements are nested within the accept
2567 -- statement for E at the point of E'Caller. The runtime uses
2568 -- this depth to find the specified entry call.
2570 for J
in reverse 0 .. Scope_Stack
.Last
loop
2571 S
:= Scope_Stack
.Table
(J
).Entity
;
2573 -- We should not reach the scope of the entry, as it should
2574 -- already have been checked in Sem_Attr that this attribute
2575 -- reference is within a matching accept statement.
2577 pragma Assert
(S
/= Conctype
);
2582 elsif Is_Entry
(S
) then
2583 Nest_Depth
:= Nest_Depth
+ 1;
2588 Unchecked_Convert_To
(Id_Kind
,
2589 Make_Function_Call
(Loc
,
2591 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2592 Parameter_Associations
=> New_List
(
2593 Make_Integer_Literal
(Loc
,
2594 Intval
=> Int
(Nest_Depth
))))));
2597 Analyze_And_Resolve
(N
, Id_Kind
);
2604 -- Transforms 'Compose into a call to the floating-point attribute
2605 -- function Compose in Fat_xxx (where xxx is the root type)
2607 -- Note: we strictly should have special code here to deal with the
2608 -- case of absurdly negative arguments (less than Integer'First)
2609 -- which will return a (signed) zero value, but it hardly seems
2610 -- worth the effort. Absurdly large positive arguments will raise
2611 -- constraint error which is fine.
2613 when Attribute_Compose
=>
2614 Expand_Fpt_Attribute_RI
(N
);
2620 when Attribute_Constrained
=> Constrained
: declare
2621 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2623 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2624 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2625 -- view of an aliased object whose subtype is constrained.
2627 ---------------------------------
2628 -- Is_Constrained_Aliased_View --
2629 ---------------------------------
2631 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2635 if Is_Entity_Name
(Obj
) then
2638 if Present
(Renamed_Object
(E
)) then
2639 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2641 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2645 return Is_Aliased_View
(Obj
)
2647 (Is_Constrained
(Etype
(Obj
))
2649 (Nkind
(Obj
) = N_Explicit_Dereference
2651 not Object_Type_Has_Constrained_Partial_View
2652 (Typ
=> Base_Type
(Etype
(Obj
)),
2653 Scop
=> Current_Scope
)));
2655 end Is_Constrained_Aliased_View
;
2657 -- Start of processing for Constrained
2660 -- Reference to a parameter where the value is passed as an extra
2661 -- actual, corresponding to the extra formal referenced by the
2662 -- Extra_Constrained field of the corresponding formal. If this
2663 -- is an entry in-parameter, it is replaced by a constant renaming
2664 -- for which Extra_Constrained is never created.
2666 if Present
(Formal_Ent
)
2667 and then Ekind
(Formal_Ent
) /= E_Constant
2668 and then Present
(Extra_Constrained
(Formal_Ent
))
2672 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2674 -- For variables with a Extra_Constrained field, we use the
2675 -- corresponding entity.
2677 elsif Nkind
(Pref
) = N_Identifier
2678 and then Ekind
(Entity
(Pref
)) = E_Variable
2679 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2683 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2685 -- For all other entity names, we can tell at compile time
2687 elsif Is_Entity_Name
(Pref
) then
2689 Ent
: constant Entity_Id
:= Entity
(Pref
);
2693 -- (RM J.4) obsolescent cases
2695 if Is_Type
(Ent
) then
2699 if Is_Private_Type
(Ent
) then
2700 Res
:= not Has_Discriminants
(Ent
)
2701 or else Is_Constrained
(Ent
);
2703 -- It not a private type, must be a generic actual type
2704 -- that corresponded to a private type. We know that this
2705 -- correspondence holds, since otherwise the reference
2706 -- within the generic template would have been illegal.
2709 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2710 Res
:= Is_Constrained
(Ent
);
2717 -- For access type, apply access check as needed
2719 if Is_Access_Type
(Ptyp
) then
2720 Apply_Access_Check
(N
);
2723 -- If the prefix is not a variable or is aliased, then
2724 -- definitely true; if it's a formal parameter without an
2725 -- associated extra formal, then treat it as constrained.
2727 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2728 -- constrained in order to set the attribute to True.
2730 if not Is_Variable
(Pref
)
2731 or else Present
(Formal_Ent
)
2732 or else (Ada_Version
< Ada_2005
2733 and then Is_Aliased_View
(Pref
))
2734 or else (Ada_Version
>= Ada_2005
2735 and then Is_Constrained_Aliased_View
(Pref
))
2739 -- Variable case, look at type to see if it is constrained.
2740 -- Note that the one case where this is not accurate (the
2741 -- procedure formal case), has been handled above.
2743 -- We use the Underlying_Type here (and below) in case the
2744 -- type is private without discriminants, but the full type
2745 -- has discriminants. This case is illegal, but we generate
2746 -- it internally for passing to the Extra_Constrained
2750 -- In Ada 2012, test for case of a limited tagged type,
2751 -- in which case the attribute is always required to
2752 -- return True. The underlying type is tested, to make
2753 -- sure we also return True for cases where there is an
2754 -- unconstrained object with an untagged limited partial
2755 -- view which has defaulted discriminants (such objects
2756 -- always produce a False in earlier versions of
2757 -- Ada). (Ada 2012: AI05-0214)
2760 Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2762 (Ada_Version
>= Ada_2012
2763 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2764 and then Is_Limited_Type
(Ptyp
));
2768 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Res
), Loc
));
2771 -- Prefix is not an entity name. These are also cases where we can
2772 -- always tell at compile time by looking at the form and type of the
2773 -- prefix. If an explicit dereference of an object with constrained
2774 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2775 -- underlying type is a limited tagged type, then Constrained is
2776 -- required to always return True (Ada 2012: AI05-0214).
2782 not Is_Variable
(Pref
)
2784 (Nkind
(Pref
) = N_Explicit_Dereference
2786 not Object_Type_Has_Constrained_Partial_View
2787 (Typ
=> Base_Type
(Ptyp
),
2788 Scop
=> Current_Scope
))
2789 or else Is_Constrained
(Underlying_Type
(Ptyp
))
2790 or else (Ada_Version
>= Ada_2012
2791 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2792 and then Is_Limited_Type
(Ptyp
))),
2796 Analyze_And_Resolve
(N
, Standard_Boolean
);
2803 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2804 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2806 when Attribute_Copy_Sign
=>
2807 Expand_Fpt_Attribute_RR
(N
);
2813 -- Transforms 'Count attribute into a call to the Count function
2815 when Attribute_Count
=> Count
: declare
2817 Conctyp
: Entity_Id
;
2819 Entry_Id
: Entity_Id
;
2824 -- If the prefix is a member of an entry family, retrieve both
2825 -- entry name and index. For a simple entry there is no index.
2827 if Nkind
(Pref
) = N_Indexed_Component
then
2828 Entnam
:= Prefix
(Pref
);
2829 Index
:= First
(Expressions
(Pref
));
2835 Entry_Id
:= Entity
(Entnam
);
2837 -- Find the concurrent type in which this attribute is referenced
2838 -- (there had better be one).
2840 Conctyp
:= Current_Scope
;
2841 while not Is_Concurrent_Type
(Conctyp
) loop
2842 Conctyp
:= Scope
(Conctyp
);
2847 if Is_Protected_Type
(Conctyp
) then
2848 case Corresponding_Runtime_Package
(Conctyp
) is
2849 when System_Tasking_Protected_Objects_Entries
=>
2850 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
2853 Make_Function_Call
(Loc
,
2855 Parameter_Associations
=> New_List
(
2857 (Find_Protection_Object
(Current_Scope
), Loc
),
2858 Entry_Index_Expression
2859 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2861 when System_Tasking_Protected_Objects_Single_Entry
=>
2863 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
2866 Make_Function_Call
(Loc
,
2868 Parameter_Associations
=> New_List
(
2870 (Find_Protection_Object
(Current_Scope
), Loc
)));
2873 raise Program_Error
;
2880 Make_Function_Call
(Loc
,
2881 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
2882 Parameter_Associations
=> New_List
(
2883 Entry_Index_Expression
(Loc
,
2884 Entry_Id
, Index
, Scope
(Entry_Id
))));
2887 -- The call returns type Natural but the context is universal integer
2888 -- so any integer type is allowed. The attribute was already resolved
2889 -- so its Etype is the required result type. If the base type of the
2890 -- context type is other than Standard.Integer we put in a conversion
2891 -- to the required type. This can be a normal typed conversion since
2892 -- both input and output types of the conversion are integer types
2894 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2895 Rewrite
(N
, Convert_To
(Typ
, Call
));
2900 Analyze_And_Resolve
(N
, Typ
);
2903 ---------------------
2904 -- Descriptor_Size --
2905 ---------------------
2907 when Attribute_Descriptor_Size
=>
2909 -- Attribute Descriptor_Size is handled by the back end when applied
2910 -- to an unconstrained array type.
2912 if Is_Array_Type
(Ptyp
)
2913 and then not Is_Constrained
(Ptyp
)
2915 Apply_Universal_Integer_Attribute_Checks
(N
);
2917 -- For any other type, the descriptor size is 0 because there is no
2918 -- actual descriptor, but the result is not formally static.
2921 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2923 Set_Is_Static_Expression
(N
, False);
2930 -- This processing is shared by Elab_Spec
2932 -- What we do is to insert the following declarations
2935 -- pragma Import (C, enn, "name___elabb/s");
2937 -- and then the Elab_Body/Spec attribute is replaced by a reference
2938 -- to this defining identifier.
2940 when Attribute_Elab_Body
2941 | Attribute_Elab_Spec
2943 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2944 -- back-end knows how to handle these attributes directly.
2946 if CodePeer_Mode
then
2951 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
2955 procedure Make_Elab_String
(Nod
: Node_Id
);
2956 -- Given Nod, an identifier, or a selected component, put the
2957 -- image into the current string literal, with double underline
2958 -- between components.
2960 ----------------------
2961 -- Make_Elab_String --
2962 ----------------------
2964 procedure Make_Elab_String
(Nod
: Node_Id
) is
2966 if Nkind
(Nod
) = N_Selected_Component
then
2967 Make_Elab_String
(Prefix
(Nod
));
2968 Store_String_Char
('_');
2969 Store_String_Char
('_');
2970 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
2973 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
2974 Get_Name_String
(Chars
(Nod
));
2977 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2978 end Make_Elab_String
;
2980 -- Start of processing for Elab_Body/Elab_Spec
2983 -- First we need to prepare the string literal for the name of
2984 -- the elaboration routine to be referenced.
2987 Make_Elab_String
(Pref
);
2988 Store_String_Chars
("___elab");
2989 Lang
:= Make_Identifier
(Loc
, Name_C
);
2991 if Id
= Attribute_Elab_Body
then
2992 Store_String_Char
('b');
2994 Store_String_Char
('s');
2999 Insert_Actions
(N
, New_List
(
3000 Make_Subprogram_Declaration
(Loc
,
3002 Make_Procedure_Specification
(Loc
,
3003 Defining_Unit_Name
=> Ent
)),
3006 Chars
=> Name_Import
,
3007 Pragma_Argument_Associations
=> New_List
(
3008 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3010 Make_Pragma_Argument_Association
(Loc
,
3011 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3013 Make_Pragma_Argument_Association
(Loc
,
3014 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3016 Set_Entity
(N
, Ent
);
3017 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3020 --------------------
3021 -- Elab_Subp_Body --
3022 --------------------
3024 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3025 -- this attribute directly, and if we are not in CodePeer mode it is
3026 -- entirely ignored ???
3028 when Attribute_Elab_Subp_Body
=>
3035 -- Elaborated is always True for preelaborated units, predefined units,
3036 -- pure units and units which have Elaborate_Body pragmas. These units
3037 -- have no elaboration entity.
3039 -- Note: The Elaborated attribute is never passed to the back end
3041 when Attribute_Elaborated
=> Elaborated
: declare
3042 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3045 if Present
(Elab_Id
) then
3048 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3049 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3051 Analyze_And_Resolve
(N
, Typ
);
3053 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3061 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3065 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3068 if Is_Non_Empty_List
(Exprs
) then
3069 Expr
:= First
(Exprs
);
3074 -- If the expression is an enumeration literal, it is replaced by the
3077 if Nkind
(Expr
) in N_Has_Entity
3078 and then Ekind
(Entity
(Expr
)) = E_Enumeration_Literal
3081 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Expr
))));
3083 -- If this is a renaming of a literal, recover the representation
3084 -- of the original. If it renames an expression there is nothing to
3087 elsif Nkind
(Expr
) in N_Has_Entity
3088 and then Ekind
(Entity
(Expr
)) = E_Constant
3089 and then Present
(Renamed_Object
(Entity
(Expr
)))
3090 and then Is_Entity_Name
(Renamed_Object
(Entity
(Expr
)))
3091 and then Ekind
(Entity
(Renamed_Object
(Entity
(Expr
)))) =
3092 E_Enumeration_Literal
3095 Make_Integer_Literal
(Loc
,
3096 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Expr
))))));
3098 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3099 -- X'Enum_Rep expands to
3103 -- This is simply a direct conversion from the enumeration type to
3104 -- the target integer type, which is treated by the back end as a
3105 -- normal integer conversion, treating the enumeration type as an
3106 -- integer, which is exactly what we want. We set Conversion_OK to
3107 -- make sure that the analyzer does not complain about what otherwise
3108 -- might be an illegal conversion.
3111 Rewrite
(N
, OK_Convert_To
(Typ
, Relocate_Node
(Expr
)));
3115 Analyze_And_Resolve
(N
, Typ
);
3122 when Attribute_Enum_Val
=> Enum_Val
: declare
3124 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3127 -- X'Enum_Val (Y) expands to
3129 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3132 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3135 Make_Raise_Constraint_Error
(Loc
,
3139 Make_Function_Call
(Loc
,
3141 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3142 Parameter_Associations
=> New_List
(
3143 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3144 New_Occurrence_Of
(Standard_False
, Loc
))),
3146 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3147 Reason
=> CE_Range_Check_Failed
));
3150 Analyze_And_Resolve
(N
, Ptyp
);
3157 -- Transforms 'Exponent into a call to the floating-point attribute
3158 -- function Exponent in Fat_xxx (where xxx is the root type)
3160 when Attribute_Exponent
=>
3161 Expand_Fpt_Attribute_R
(N
);
3167 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3169 when Attribute_External_Tag
=>
3171 Make_Function_Call
(Loc
,
3173 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3174 Parameter_Associations
=> New_List
(
3175 Make_Attribute_Reference
(Loc
,
3176 Attribute_Name
=> Name_Tag
,
3177 Prefix
=> Prefix
(N
)))));
3179 Analyze_And_Resolve
(N
, Standard_String
);
3181 -----------------------
3182 -- Finalization_Size --
3183 -----------------------
3185 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3186 function Calculate_Header_Size
return Node_Id
;
3187 -- Generate a runtime call to calculate the size of the hidden header
3188 -- along with any added padding which would precede a heap-allocated
3189 -- object of the prefix type.
3191 ---------------------------
3192 -- Calculate_Header_Size --
3193 ---------------------------
3195 function Calculate_Header_Size
return Node_Id
is
3198 -- Universal_Integer
3199 -- (Header_Size_With_Padding (Pref'Alignment))
3202 Convert_To
(Universal_Integer
,
3203 Make_Function_Call
(Loc
,
3205 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3207 Parameter_Associations
=> New_List
(
3208 Make_Attribute_Reference
(Loc
,
3209 Prefix
=> New_Copy_Tree
(Pref
),
3210 Attribute_Name
=> Name_Alignment
))));
3211 end Calculate_Header_Size
;
3217 -- Start of Finalization_Size
3220 -- An object of a class-wide type first requires a runtime check to
3221 -- determine whether it is actually controlled or not. Depending on
3222 -- the outcome of this check, the Finalization_Size of the object
3223 -- may be zero or some positive value.
3225 -- In this scenario, Pref'Finalization_Size is expanded into
3227 -- Size : Integer := 0;
3229 -- if Needs_Finalization (Pref'Tag) then
3231 -- Universal_Integer
3232 -- (Header_Size_With_Padding (Pref'Alignment));
3235 -- and the attribute reference is replaced with a reference to Size.
3237 if Is_Class_Wide_Type
(Ptyp
) then
3238 Size
:= Make_Temporary
(Loc
, 'S');
3240 Insert_Actions
(N
, New_List
(
3243 -- Size : Integer := 0;
3245 Make_Object_Declaration
(Loc
,
3246 Defining_Identifier
=> Size
,
3247 Object_Definition
=>
3248 New_Occurrence_Of
(Standard_Integer
, Loc
),
3249 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3252 -- if Needs_Finalization (Pref'Tag) then
3254 -- Universal_Integer
3255 -- (Header_Size_With_Padding (Pref'Alignment));
3258 Make_If_Statement
(Loc
,
3260 Make_Function_Call
(Loc
,
3262 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3264 Parameter_Associations
=> New_List
(
3265 Make_Attribute_Reference
(Loc
,
3266 Prefix
=> New_Copy_Tree
(Pref
),
3267 Attribute_Name
=> Name_Tag
))),
3269 Then_Statements
=> New_List
(
3270 Make_Assignment_Statement
(Loc
,
3271 Name
=> New_Occurrence_Of
(Size
, Loc
),
3272 Expression
=> Calculate_Header_Size
)))));
3274 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3276 -- The prefix is known to be controlled at compile time. Calculate
3277 -- Finalization_Size by calling function Header_Size_With_Padding.
3279 elsif Needs_Finalization
(Ptyp
) then
3280 Rewrite
(N
, Calculate_Header_Size
);
3282 -- The prefix is not an object with controlled parts, so its
3283 -- Finalization_Size is zero.
3286 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3289 -- Due to cases where the entity type of the attribute is already
3290 -- resolved the rewritten N must get re-resolved to its appropriate
3293 Analyze_And_Resolve
(N
, Typ
);
3294 end Finalization_Size
;
3300 when Attribute_First
=>
3302 -- If the prefix type is a constrained packed array type which
3303 -- already has a Packed_Array_Impl_Type representation defined, then
3304 -- replace this attribute with a direct reference to 'First of the
3305 -- appropriate index subtype (since otherwise the back end will try
3306 -- to give us the value of 'First for this implementation type).
3308 if Is_Constrained_Packed_Array
(Ptyp
) then
3310 Make_Attribute_Reference
(Loc
,
3311 Attribute_Name
=> Name_First
,
3313 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3314 Analyze_And_Resolve
(N
, Typ
);
3316 -- For access type, apply access check as needed
3318 elsif Is_Access_Type
(Ptyp
) then
3319 Apply_Access_Check
(N
);
3321 -- For scalar type, if low bound is a reference to an entity, just
3322 -- replace with a direct reference. Note that we can only have a
3323 -- reference to a constant entity at this stage, anything else would
3324 -- have already been rewritten.
3326 elsif Is_Scalar_Type
(Ptyp
) then
3328 Lo
: constant Node_Id
:= Type_Low_Bound
(Ptyp
);
3330 if Is_Entity_Name
(Lo
) then
3331 Rewrite
(N
, New_Occurrence_Of
(Entity
(Lo
), Loc
));
3340 -- Compute this if component clause was present, otherwise we leave the
3341 -- computation to be completed in the back-end, since we don't know what
3342 -- layout will be chosen.
3344 when Attribute_First_Bit
=> First_Bit_Attr
: declare
3345 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3348 -- In Ada 2005 (or later) if we have the non-default bit order, then
3349 -- we return the original value as given in the component clause
3350 -- (RM 2005 13.5.2(3/2)).
3352 if Present
(Component_Clause
(CE
))
3353 and then Ada_Version
>= Ada_2005
3354 and then Reverse_Bit_Order
(Scope
(CE
))
3357 Make_Integer_Literal
(Loc
,
3358 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
3359 Analyze_And_Resolve
(N
, Typ
);
3361 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3362 -- rewrite with normalized value if we know it statically.
3364 elsif Known_Static_Component_Bit_Offset
(CE
) then
3366 Make_Integer_Literal
(Loc
,
3367 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
3368 Analyze_And_Resolve
(N
, Typ
);
3370 -- Otherwise left to back end, just do universal integer checks
3373 Apply_Universal_Integer_Attribute_Checks
(N
);
3377 --------------------------------
3378 -- Fixed_Value, Integer_Value --
3379 --------------------------------
3383 -- fixtype'Fixed_Value (integer-value)
3384 -- inttype'Fixed_Value (fixed-value)
3388 -- fixtype (integer-value)
3389 -- inttype (fixed-value)
3393 -- We do all the required analysis of the conversion here, because we do
3394 -- not want this to go through the fixed-point conversion circuits. Note
3395 -- that the back end always treats fixed-point as equivalent to the
3396 -- corresponding integer type anyway.
3398 when Attribute_Fixed_Value
3399 | Attribute_Integer_Value
3402 Make_Type_Conversion
(Loc
,
3403 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3404 Expression
=> Relocate_Node
(First
(Exprs
))));
3405 Set_Etype
(N
, Entity
(Pref
));
3408 -- Note: it might appear that a properly analyzed unchecked
3409 -- conversion would be just fine here, but that's not the case,
3410 -- since the full range checks performed by the following call
3413 Apply_Type_Conversion_Checks
(N
);
3419 -- Transforms 'Floor into a call to the floating-point attribute
3420 -- function Floor in Fat_xxx (where xxx is the root type)
3422 when Attribute_Floor
=>
3423 Expand_Fpt_Attribute_R
(N
);
3429 -- For the fixed-point type Typ:
3435 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3436 -- Universal_Real (Type'Last))
3438 -- Note that we know that the type is a non-static subtype, or Fore
3439 -- would have itself been computed dynamically in Eval_Attribute.
3441 when Attribute_Fore
=>
3444 Make_Function_Call
(Loc
,
3446 New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
3448 Parameter_Associations
=> New_List
(
3449 Convert_To
(Universal_Real
,
3450 Make_Attribute_Reference
(Loc
,
3451 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3452 Attribute_Name
=> Name_First
)),
3454 Convert_To
(Universal_Real
,
3455 Make_Attribute_Reference
(Loc
,
3456 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3457 Attribute_Name
=> Name_Last
))))));
3459 Analyze_And_Resolve
(N
, Typ
);
3465 -- Transforms 'Fraction into a call to the floating-point attribute
3466 -- function Fraction in Fat_xxx (where xxx is the root type)
3468 when Attribute_Fraction
=>
3469 Expand_Fpt_Attribute_R
(N
);
3475 when Attribute_From_Any
=> From_Any
: declare
3476 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3477 Decls
: constant List_Id
:= New_List
;
3481 Build_From_Any_Call
(P_Type
,
3482 Relocate_Node
(First
(Exprs
)),
3484 Insert_Actions
(N
, Decls
);
3485 Analyze_And_Resolve
(N
, P_Type
);
3488 ----------------------
3489 -- Has_Same_Storage --
3490 ----------------------
3492 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3493 Loc
: constant Source_Ptr
:= Sloc
(N
);
3495 X
: constant Node_Id
:= Prefix
(N
);
3496 Y
: constant Node_Id
:= First
(Expressions
(N
));
3501 -- Rhe expressions for their addresses
3505 -- Rhe expressions for their sizes
3508 -- The attribute is expanded as:
3510 -- (X'address = Y'address)
3511 -- and then (X'Size = Y'Size)
3513 -- If both arguments have the same Etype the second conjunct can be
3517 Make_Attribute_Reference
(Loc
,
3518 Attribute_Name
=> Name_Address
,
3519 Prefix
=> New_Copy_Tree
(X
));
3522 Make_Attribute_Reference
(Loc
,
3523 Attribute_Name
=> Name_Address
,
3524 Prefix
=> New_Copy_Tree
(Y
));
3527 Make_Attribute_Reference
(Loc
,
3528 Attribute_Name
=> Name_Size
,
3529 Prefix
=> New_Copy_Tree
(X
));
3532 Make_Attribute_Reference
(Loc
,
3533 Attribute_Name
=> Name_Size
,
3534 Prefix
=> New_Copy_Tree
(Y
));
3536 if Etype
(X
) = Etype
(Y
) then
3539 Left_Opnd
=> X_Addr
,
3540 Right_Opnd
=> Y_Addr
));
3546 Left_Opnd
=> X_Addr
,
3547 Right_Opnd
=> Y_Addr
),
3550 Left_Opnd
=> X_Size
,
3551 Right_Opnd
=> Y_Size
)));
3554 Analyze_And_Resolve
(N
, Standard_Boolean
);
3555 end Has_Same_Storage
;
3561 -- For an exception returns a reference to the exception data:
3562 -- Exception_Id!(Prefix'Reference)
3564 -- For a task it returns a reference to the _task_id component of
3565 -- corresponding record:
3567 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3569 -- in Ada.Task_Identification
3571 when Attribute_Identity
=> Identity
: declare
3572 Id_Kind
: Entity_Id
;
3575 if Ptyp
= Standard_Exception_Type
then
3576 Id_Kind
:= RTE
(RE_Exception_Id
);
3578 if Present
(Renamed_Object
(Entity
(Pref
))) then
3579 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3583 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3585 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3587 -- If the prefix is a task interface, the Task_Id is obtained
3588 -- dynamically through a dispatching call, as for other task
3589 -- attributes applied to interfaces.
3591 if Ada_Version
>= Ada_2005
3592 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3593 and then Is_Interface
(Ptyp
)
3594 and then Is_Task_Interface
(Ptyp
)
3597 Unchecked_Convert_To
3598 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
3602 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3606 Analyze_And_Resolve
(N
, Id_Kind
);
3613 -- Image attribute is handled in separate unit Exp_Imgv
3615 when Attribute_Image
=>
3617 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3618 -- back-end knows how to handle this attribute directly.
3620 if CodePeer_Mode
then
3624 Exp_Imgv
.Expand_Image_Attribute
(N
);
3630 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3632 when Attribute_Img
=>
3634 Make_Attribute_Reference
(Loc
,
3635 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3636 Attribute_Name
=> Name_Image
,
3637 Expressions
=> New_List
(Relocate_Node
(Pref
))));
3639 Analyze_And_Resolve
(N
, Standard_String
);
3645 when Attribute_Input
=> Input
: declare
3646 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3647 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3648 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3649 Strm
: constant Node_Id
:= First
(Exprs
);
3657 Cntrl
: Node_Id
:= Empty
;
3658 -- Value for controlling argument in call. Always Empty except in
3659 -- the dispatching (class-wide type) case, where it is a reference
3660 -- to the dummy object initialized to the right internal tag.
3662 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3663 -- The expansion of the attribute reference may generate a call to
3664 -- a user-defined stream subprogram that is frozen by the call. This
3665 -- can lead to access-before-elaboration problem if the reference
3666 -- appears in an object declaration and the subprogram body has not
3667 -- been seen. The freezing of the subprogram requires special code
3668 -- because it appears in an expanded context where expressions do
3669 -- not freeze their constituents.
3671 ------------------------------
3672 -- Freeze_Stream_Subprogram --
3673 ------------------------------
3675 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3676 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3680 -- If this is user-defined subprogram, the corresponding
3681 -- stream function appears as a renaming-as-body, and the
3682 -- user subprogram must be retrieved by tree traversal.
3685 and then Nkind
(Decl
) = N_Subprogram_Declaration
3686 and then Present
(Corresponding_Body
(Decl
))
3688 Bod
:= Corresponding_Body
(Decl
);
3690 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3691 N_Subprogram_Renaming_Declaration
3693 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3696 end Freeze_Stream_Subprogram
;
3698 -- Start of processing for Input
3701 -- If no underlying type, we have an error that will be diagnosed
3702 -- elsewhere, so here we just completely ignore the expansion.
3708 -- Stream operations can appear in user code even if the restriction
3709 -- No_Streams is active (for example, when instantiating a predefined
3710 -- container). In that case rewrite the attribute as a Raise to
3711 -- prevent any run-time use.
3713 if Restriction_Active
(No_Streams
) then
3715 Make_Raise_Program_Error
(Sloc
(N
),
3716 Reason
=> PE_Stream_Operation_Not_Allowed
));
3717 Set_Etype
(N
, B_Type
);
3721 -- If there is a TSS for Input, just call it
3723 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3725 if Present
(Fname
) then
3729 -- If there is a Stream_Convert pragma, use it, we rewrite
3731 -- sourcetyp'Input (stream)
3735 -- sourcetyp (streamread (strmtyp'Input (stream)));
3737 -- where streamread is the given Read function that converts an
3738 -- argument of type strmtyp to type sourcetyp or a type from which
3739 -- it is derived (extra conversion required for the derived case).
3741 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3743 if Present
(Prag
) then
3744 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3745 Rfunc
:= Entity
(Expression
(Arg2
));
3749 Make_Function_Call
(Loc
,
3750 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3751 Parameter_Associations
=> New_List
(
3752 Make_Attribute_Reference
(Loc
,
3755 (Etype
(First_Formal
(Rfunc
)), Loc
),
3756 Attribute_Name
=> Name_Input
,
3757 Expressions
=> Exprs
)))));
3759 Analyze_And_Resolve
(N
, B_Type
);
3764 elsif Is_Elementary_Type
(U_Type
) then
3766 -- A special case arises if we have a defined _Read routine,
3767 -- since in this case we are required to call this routine.
3770 Typ
: Entity_Id
:= P_Type
;
3772 if Present
(Full_View
(Typ
)) then
3773 Typ
:= Full_View
(Typ
);
3776 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Read
)) then
3777 Build_Record_Or_Elementary_Input_Function
3778 (Loc
, Typ
, Decl
, Fname
, Use_Underlying
=> False);
3779 Insert_Action
(N
, Decl
);
3781 -- For normal cases, we call the I_xxx routine directly
3784 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3785 Analyze_And_Resolve
(N
, P_Type
);
3792 elsif Is_Array_Type
(U_Type
) then
3793 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3794 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3796 -- Dispatching case with class-wide type
3798 elsif Is_Class_Wide_Type
(P_Type
) then
3800 -- No need to do anything else compiling under restriction
3801 -- No_Dispatching_Calls. During the semantic analysis we
3802 -- already notified such violation.
3804 if Restriction_Active
(No_Dispatching_Calls
) then
3809 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3813 -- Read the internal tag (RM 13.13.2(34)) and use it to
3814 -- initialize a dummy tag value:
3816 -- Descendant_Tag (String'Input (Strm), P_Type);
3818 -- This value is used only to provide a controlling
3819 -- argument for the eventual _Input call. Descendant_Tag is
3820 -- called rather than Internal_Tag to ensure that we have a
3821 -- tag for a type that is descended from the prefix type and
3822 -- declared at the same accessibility level (the exception
3823 -- Tag_Error will be raised otherwise). The level check is
3824 -- required for Ada 2005 because tagged types can be
3825 -- extended in nested scopes (AI-344).
3827 -- Note: we used to generate an explicit declaration of a
3828 -- constant Ada.Tags.Tag object, and use an occurrence of
3829 -- this constant in Cntrl, but this caused a secondary stack
3833 Make_Function_Call
(Loc
,
3835 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3836 Parameter_Associations
=> New_List
(
3837 Make_Attribute_Reference
(Loc
,
3839 New_Occurrence_Of
(Standard_String
, Loc
),
3840 Attribute_Name
=> Name_Input
,
3841 Expressions
=> New_List
(
3842 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
3843 Make_Attribute_Reference
(Loc
,
3844 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
3845 Attribute_Name
=> Name_Tag
)));
3846 Set_Etype
(Expr
, RTE
(RE_Tag
));
3848 -- Now we need to get the entity for the call, and construct
3849 -- a function call node, where we preset a reference to Dnn
3850 -- as the controlling argument (doing an unchecked convert
3851 -- to the class-wide tagged type to make it look like a real
3854 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3855 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
3856 Set_Etype
(Cntrl
, P_Type
);
3857 Set_Parent
(Cntrl
, N
);
3860 -- For tagged types, use the primitive Input function
3862 elsif Is_Tagged_Type
(U_Type
) then
3863 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3865 -- All other record type cases, including protected records. The
3866 -- latter only arise for expander generated code for handling
3867 -- shared passive partition access.
3871 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3873 -- Ada 2005 (AI-216): Program_Error is raised executing default
3874 -- implementation of the Input attribute of an unchecked union
3875 -- type if the type lacks default discriminant values.
3877 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3878 and then No
(Discriminant_Constraint
(U_Type
))
3881 Make_Raise_Program_Error
(Loc
,
3882 Reason
=> PE_Unchecked_Union_Restriction
));
3887 -- Build the type's Input function, passing the subtype rather
3888 -- than its base type, because checks are needed in the case of
3889 -- constrained discriminants (see Ada 2012 AI05-0192).
3891 Build_Record_Or_Elementary_Input_Function
3892 (Loc
, U_Type
, Decl
, Fname
);
3893 Insert_Action
(N
, Decl
);
3895 if Nkind
(Parent
(N
)) = N_Object_Declaration
3896 and then Is_Record_Type
(U_Type
)
3898 -- The stream function may contain calls to user-defined
3899 -- Read procedures for individual components.
3906 Comp
:= First_Component
(U_Type
);
3907 while Present
(Comp
) loop
3909 Find_Stream_Subprogram
3910 (Etype
(Comp
), TSS_Stream_Read
);
3912 if Present
(Func
) then
3913 Freeze_Stream_Subprogram
(Func
);
3916 Next_Component
(Comp
);
3923 -- If we fall through, Fname is the function to be called. The result
3924 -- is obtained by calling the appropriate function, then converting
3925 -- the result. The conversion does a subtype check.
3928 Make_Function_Call
(Loc
,
3929 Name
=> New_Occurrence_Of
(Fname
, Loc
),
3930 Parameter_Associations
=> New_List
(
3931 Relocate_Node
(Strm
)));
3933 Set_Controlling_Argument
(Call
, Cntrl
);
3934 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
3935 Analyze_And_Resolve
(N
, P_Type
);
3937 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
3938 Freeze_Stream_Subprogram
(Fname
);
3946 when Attribute_Invalid_Value
=>
3947 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
3953 when Attribute_Last
=>
3955 -- If the prefix type is a constrained packed array type which
3956 -- already has a Packed_Array_Impl_Type representation defined, then
3957 -- replace this attribute with a direct reference to 'Last of the
3958 -- appropriate index subtype (since otherwise the back end will try
3959 -- to give us the value of 'Last for this implementation type).
3961 if Is_Constrained_Packed_Array
(Ptyp
) then
3963 Make_Attribute_Reference
(Loc
,
3964 Attribute_Name
=> Name_Last
,
3965 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3966 Analyze_And_Resolve
(N
, Typ
);
3968 -- For access type, apply access check as needed
3970 elsif Is_Access_Type
(Ptyp
) then
3971 Apply_Access_Check
(N
);
3973 -- For scalar type, if low bound is a reference to an entity, just
3974 -- replace with a direct reference. Note that we can only have a
3975 -- reference to a constant entity at this stage, anything else would
3976 -- have already been rewritten.
3978 elsif Is_Scalar_Type
(Ptyp
) then
3980 Hi
: constant Node_Id
:= Type_High_Bound
(Ptyp
);
3982 if Is_Entity_Name
(Hi
) then
3983 Rewrite
(N
, New_Occurrence_Of
(Entity
(Hi
), Loc
));
3992 -- We compute this if a component clause was present, otherwise we leave
3993 -- the computation up to the back end, since we don't know what layout
3996 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
3997 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4000 -- In Ada 2005 (or later) if we have the non-default bit order, then
4001 -- we return the original value as given in the component clause
4002 -- (RM 2005 13.5.2(3/2)).
4004 if Present
(Component_Clause
(CE
))
4005 and then Ada_Version
>= Ada_2005
4006 and then Reverse_Bit_Order
(Scope
(CE
))
4009 Make_Integer_Literal
(Loc
,
4010 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
4011 Analyze_And_Resolve
(N
, Typ
);
4013 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4014 -- rewrite with normalized value if we know it statically.
4016 elsif Known_Static_Component_Bit_Offset
(CE
)
4017 and then Known_Static_Esize
(CE
)
4020 Make_Integer_Literal
(Loc
,
4021 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
4023 Analyze_And_Resolve
(N
, Typ
);
4025 -- Otherwise leave to back end, just apply universal integer checks
4028 Apply_Universal_Integer_Attribute_Checks
(N
);
4036 -- Transforms 'Leading_Part into a call to the floating-point attribute
4037 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4039 -- Note: strictly, we should generate special case code to deal with
4040 -- absurdly large positive arguments (greater than Integer'Last), which
4041 -- result in returning the first argument unchanged, but it hardly seems
4042 -- worth the effort. We raise constraint error for absurdly negative
4043 -- arguments which is fine.
4045 when Attribute_Leading_Part
=>
4046 Expand_Fpt_Attribute_RI
(N
);
4052 when Attribute_Length
=> Length
: declare
4057 -- Processing for packed array types
4059 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
4060 Ityp
:= Get_Index_Subtype
(N
);
4062 -- If the index type, Ityp, is an enumeration type with holes,
4063 -- then we calculate X'Length explicitly using
4066 -- (0, Ityp'Pos (X'Last (N)) -
4067 -- Ityp'Pos (X'First (N)) + 1);
4069 -- Since the bounds in the template are the representation values
4070 -- and the back end would get the wrong value.
4072 if Is_Enumeration_Type
(Ityp
)
4073 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4078 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4082 Make_Attribute_Reference
(Loc
,
4083 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4084 Attribute_Name
=> Name_Max
,
4085 Expressions
=> New_List
4086 (Make_Integer_Literal
(Loc
, 0),
4090 Make_Op_Subtract
(Loc
,
4092 Make_Attribute_Reference
(Loc
,
4093 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4094 Attribute_Name
=> Name_Pos
,
4096 Expressions
=> New_List
(
4097 Make_Attribute_Reference
(Loc
,
4098 Prefix
=> Duplicate_Subexpr
(Pref
),
4099 Attribute_Name
=> Name_Last
,
4100 Expressions
=> New_List
(
4101 Make_Integer_Literal
(Loc
, Xnum
))))),
4104 Make_Attribute_Reference
(Loc
,
4105 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4106 Attribute_Name
=> Name_Pos
,
4108 Expressions
=> New_List
(
4109 Make_Attribute_Reference
(Loc
,
4111 Duplicate_Subexpr_No_Checks
(Pref
),
4112 Attribute_Name
=> Name_First
,
4113 Expressions
=> New_List
(
4114 Make_Integer_Literal
(Loc
, Xnum
)))))),
4116 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4118 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4121 -- If the prefix type is a constrained packed array type which
4122 -- already has a Packed_Array_Impl_Type representation defined,
4123 -- then replace this attribute with a reference to 'Range_Length
4124 -- of the appropriate index subtype (since otherwise the
4125 -- back end will try to give us the value of 'Length for
4126 -- this implementation type).s
4128 elsif Is_Constrained
(Ptyp
) then
4130 Make_Attribute_Reference
(Loc
,
4131 Attribute_Name
=> Name_Range_Length
,
4132 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4133 Analyze_And_Resolve
(N
, Typ
);
4138 elsif Is_Access_Type
(Ptyp
) then
4139 Apply_Access_Check
(N
);
4141 -- If the designated type is a packed array type, then we convert
4142 -- the reference to:
4145 -- xtyp'Pos (Pref'Last (Expr)) -
4146 -- xtyp'Pos (Pref'First (Expr)));
4148 -- This is a bit complex, but it is the easiest thing to do that
4149 -- works in all cases including enum types with holes xtyp here
4150 -- is the appropriate index type.
4153 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4157 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
4158 Xtyp
:= Get_Index_Subtype
(N
);
4161 Make_Attribute_Reference
(Loc
,
4162 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4163 Attribute_Name
=> Name_Max
,
4164 Expressions
=> New_List
(
4165 Make_Integer_Literal
(Loc
, 0),
4168 Make_Integer_Literal
(Loc
, 1),
4169 Make_Op_Subtract
(Loc
,
4171 Make_Attribute_Reference
(Loc
,
4172 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4173 Attribute_Name
=> Name_Pos
,
4174 Expressions
=> New_List
(
4175 Make_Attribute_Reference
(Loc
,
4176 Prefix
=> Duplicate_Subexpr
(Pref
),
4177 Attribute_Name
=> Name_Last
,
4179 New_Copy_List
(Exprs
)))),
4182 Make_Attribute_Reference
(Loc
,
4183 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4184 Attribute_Name
=> Name_Pos
,
4185 Expressions
=> New_List
(
4186 Make_Attribute_Reference
(Loc
,
4188 Duplicate_Subexpr_No_Checks
(Pref
),
4189 Attribute_Name
=> Name_First
,
4191 New_Copy_List
(Exprs
)))))))));
4193 Analyze_And_Resolve
(N
, Typ
);
4197 -- Otherwise leave it to the back end
4200 Apply_Universal_Integer_Attribute_Checks
(N
);
4204 -- Attribute Loop_Entry is replaced with a reference to a constant value
4205 -- which captures the prefix at the entry point of the related loop. The
4206 -- loop itself may be transformed into a conditional block.
4208 when Attribute_Loop_Entry
=>
4209 Expand_Loop_Entry_Attribute
(N
);
4215 -- Transforms 'Machine into a call to the floating-point attribute
4216 -- function Machine in Fat_xxx (where xxx is the root type).
4217 -- Expansion is avoided for cases the back end can handle directly.
4219 when Attribute_Machine
=>
4220 if not Is_Inline_Floating_Point_Attribute
(N
) then
4221 Expand_Fpt_Attribute_R
(N
);
4224 ----------------------
4225 -- Machine_Rounding --
4226 ----------------------
4228 -- Transforms 'Machine_Rounding into a call to the floating-point
4229 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4230 -- type). Expansion is avoided for cases the back end can handle
4233 when Attribute_Machine_Rounding
=>
4234 if not Is_Inline_Floating_Point_Attribute
(N
) then
4235 Expand_Fpt_Attribute_R
(N
);
4242 -- Machine_Size is equivalent to Object_Size, so transform it into
4243 -- Object_Size and that way the back end never sees Machine_Size.
4245 when Attribute_Machine_Size
=>
4247 Make_Attribute_Reference
(Loc
,
4248 Prefix
=> Prefix
(N
),
4249 Attribute_Name
=> Name_Object_Size
));
4251 Analyze_And_Resolve
(N
, Typ
);
4257 -- The only case that can get this far is the dynamic case of the old
4258 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4265 -- ityp (System.Mantissa.Mantissa_Value
4266 -- (Integer'Integer_Value (typ'First),
4267 -- Integer'Integer_Value (typ'Last)));
4269 when Attribute_Mantissa
=>
4272 Make_Function_Call
(Loc
,
4274 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4276 Parameter_Associations
=> New_List
(
4277 Make_Attribute_Reference
(Loc
,
4278 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4279 Attribute_Name
=> Name_Integer_Value
,
4280 Expressions
=> New_List
(
4281 Make_Attribute_Reference
(Loc
,
4282 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4283 Attribute_Name
=> Name_First
))),
4285 Make_Attribute_Reference
(Loc
,
4286 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4287 Attribute_Name
=> Name_Integer_Value
,
4288 Expressions
=> New_List
(
4289 Make_Attribute_Reference
(Loc
,
4290 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4291 Attribute_Name
=> Name_Last
)))))));
4293 Analyze_And_Resolve
(N
, Typ
);
4299 when Attribute_Max
=>
4300 Expand_Min_Max_Attribute
(N
);
4302 ----------------------------------
4303 -- Max_Size_In_Storage_Elements --
4304 ----------------------------------
4306 when Attribute_Max_Size_In_Storage_Elements
=> declare
4307 Typ
: constant Entity_Id
:= Etype
(N
);
4310 Conversion_Added
: Boolean := False;
4311 -- A flag which tracks whether the original attribute has been
4312 -- wrapped inside a type conversion.
4315 -- If the prefix is X'Class, we transform it into a direct reference
4316 -- to the class-wide type, because the back end must not see a 'Class
4317 -- reference. See also 'Size.
4319 if Is_Entity_Name
(Pref
)
4320 and then Is_Class_Wide_Type
(Entity
(Pref
))
4322 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4326 Apply_Universal_Integer_Attribute_Checks
(N
);
4328 -- The universal integer check may sometimes add a type conversion,
4329 -- retrieve the original attribute reference from the expression.
4333 if Nkind
(Attr
) = N_Type_Conversion
then
4334 Attr
:= Expression
(Attr
);
4335 Conversion_Added
:= True;
4338 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
4340 -- Heap-allocated controlled objects contain two extra pointers which
4341 -- are not part of the actual type. Transform the attribute reference
4342 -- into a runtime expression to add the size of the hidden header.
4344 if Needs_Finalization
(Ptyp
)
4345 and then not Header_Size_Added
(Attr
)
4347 Set_Header_Size_Added
(Attr
);
4350 -- P'Max_Size_In_Storage_Elements +
4351 -- Universal_Integer
4352 -- (Header_Size_With_Padding (Ptyp'Alignment))
4356 Left_Opnd
=> Relocate_Node
(Attr
),
4358 Convert_To
(Universal_Integer
,
4359 Make_Function_Call
(Loc
,
4362 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4364 Parameter_Associations
=> New_List
(
4365 Make_Attribute_Reference
(Loc
,
4367 New_Occurrence_Of
(Ptyp
, Loc
),
4368 Attribute_Name
=> Name_Alignment
))))));
4370 -- Add a conversion to the target type
4372 if not Conversion_Added
then
4374 Make_Type_Conversion
(Loc
,
4375 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4376 Expression
=> Relocate_Node
(Attr
)));
4384 --------------------
4385 -- Mechanism_Code --
4386 --------------------
4388 when Attribute_Mechanism_Code
=>
4390 -- We must replace the prefix in the renamed case
4392 if Is_Entity_Name
(Pref
)
4393 and then Present
(Alias
(Entity
(Pref
)))
4395 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4402 when Attribute_Min
=>
4403 Expand_Min_Max_Attribute
(N
);
4409 when Attribute_Mod
=> Mod_Case
: declare
4410 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4411 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
4412 Modv
: constant Uint
:= Modulus
(Btyp
);
4416 -- This is not so simple. The issue is what type to use for the
4417 -- computation of the modular value.
4419 -- The easy case is when the modulus value is within the bounds
4420 -- of the signed integer type of the argument. In this case we can
4421 -- just do the computation in that signed integer type, and then
4422 -- do an ordinary conversion to the target type.
4424 if Modv
<= Expr_Value
(Hi
) then
4429 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4431 -- Here we know that the modulus is larger than type'Last of the
4432 -- integer type. There are two cases to consider:
4434 -- a) The integer value is non-negative. In this case, it is
4435 -- returned as the result (since it is less than the modulus).
4437 -- b) The integer value is negative. In this case, we know that the
4438 -- result is modulus + value, where the value might be as small as
4439 -- -modulus. The trouble is what type do we use to do the subtract.
4440 -- No type will do, since modulus can be as big as 2**64, and no
4441 -- integer type accommodates this value. Let's do bit of algebra
4444 -- = modulus - (-value)
4445 -- = (modulus - 1) - (-value - 1)
4447 -- Now modulus - 1 is certainly in range of the modular type.
4448 -- -value is in the range 1 .. modulus, so -value -1 is in the
4449 -- range 0 .. modulus-1 which is in range of the modular type.
4450 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4451 -- which we can compute using the integer base type.
4453 -- Once this is done we analyze the if expression without range
4454 -- checks, because we know everything is in range, and we want
4455 -- to prevent spurious warnings on either branch.
4459 Make_If_Expression
(Loc
,
4460 Expressions
=> New_List
(
4462 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4463 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4466 Duplicate_Subexpr_No_Checks
(Arg
)),
4468 Make_Op_Subtract
(Loc
,
4470 Make_Integer_Literal
(Loc
,
4471 Intval
=> Modv
- 1),
4477 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4479 Make_Integer_Literal
(Loc
,
4480 Intval
=> 1))))))));
4484 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4491 -- Transforms 'Model into a call to the floating-point attribute
4492 -- function Model in Fat_xxx (where xxx is the root type).
4493 -- Expansion is avoided for cases the back end can handle directly.
4495 when Attribute_Model
=>
4496 if not Is_Inline_Floating_Point_Attribute
(N
) then
4497 Expand_Fpt_Attribute_R
(N
);
4504 -- The processing for Object_Size shares the processing for Size
4510 when Attribute_Old
=> Old
: declare
4511 Typ
: constant Entity_Id
:= Etype
(N
);
4512 CW_Temp
: Entity_Id
;
4519 -- Generating C code we don't need to expand this attribute when
4520 -- we are analyzing the internally built nested postconditions
4521 -- procedure since it will be expanded inline (and later it will
4522 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4523 -- performed in such case then the compiler generates unreferenced
4524 -- extra temporaries.
4526 if Modify_Tree_For_C
4527 and then Chars
(Current_Scope
) = Name_uPostconditions
4532 -- Climb the parent chain looking for subprogram _Postconditions
4535 while Present
(Subp
) loop
4536 exit when Nkind
(Subp
) = N_Subprogram_Body
4537 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4539 -- If assertions are disabled, no need to create the declaration
4540 -- that preserves the value. The postcondition pragma in which
4541 -- 'Old appears will be checked or disabled according to the
4542 -- current policy in effect.
4544 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4548 Subp
:= Parent
(Subp
);
4551 -- 'Old can only appear in a postcondition, the generated body of
4552 -- _Postconditions must be in the tree (or inlined if we are
4553 -- generating C code).
4557 or else (Modify_Tree_For_C
and then In_Inlined_Body
));
4559 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4561 -- Set the entity kind now in order to mark the temporary as a
4562 -- handler of attribute 'Old's prefix.
4564 Set_Ekind
(Temp
, E_Constant
);
4565 Set_Stores_Attribute_Old_Prefix
(Temp
);
4567 -- Push the scope of the related subprogram where _Postcondition
4568 -- resides as this ensures that the object will be analyzed in the
4571 if Present
(Subp
) then
4572 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4574 -- No need to push the scope when generating C code since the
4575 -- _Postcondition procedure has been inlined.
4577 else pragma Assert
(Modify_Tree_For_C
);
4578 pragma Assert
(In_Inlined_Body
);
4582 -- Locate the insertion place of the internal temporary that saves
4585 if Present
(Subp
) then
4588 -- Generating C, the postcondition procedure has been inlined and the
4589 -- temporary is added before the first declaration of the enclosing
4592 else pragma Assert
(Modify_Tree_For_C
);
4594 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
4595 Ins_Nod
:= Parent
(Ins_Nod
);
4598 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
4601 -- Preserve the tag of the prefix by offering a specific view of the
4602 -- class-wide version of the prefix.
4604 if Is_Tagged_Type
(Typ
) then
4607 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4609 CW_Temp
:= Make_Temporary
(Loc
, 'T');
4610 CW_Typ
:= Class_Wide_Type
(Typ
);
4612 Insert_Before_And_Analyze
(Ins_Nod
,
4613 Make_Object_Declaration
(Loc
,
4614 Defining_Identifier
=> CW_Temp
,
4615 Constant_Present
=> True,
4616 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
4618 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
4621 -- Temp : Typ renames Typ (CW_Temp);
4623 Insert_Before_And_Analyze
(Ins_Nod
,
4624 Make_Object_Renaming_Declaration
(Loc
,
4625 Defining_Identifier
=> Temp
,
4626 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4628 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
4634 -- Temp : constant Typ := Pref;
4636 Insert_Before_And_Analyze
(Ins_Nod
,
4637 Make_Object_Declaration
(Loc
,
4638 Defining_Identifier
=> Temp
,
4639 Constant_Present
=> True,
4640 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
4641 Expression
=> Relocate_Node
(Pref
)));
4644 if Present
(Subp
) then
4648 -- Ensure that the prefix of attribute 'Old is valid. The check must
4649 -- be inserted after the expansion of the attribute has taken place
4650 -- to reflect the new placement of the prefix.
4652 if Validity_Checks_On
and then Validity_Check_Operands
then
4653 Ensure_Valid
(Pref
);
4656 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4659 ----------------------
4660 -- Overlaps_Storage --
4661 ----------------------
4663 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4664 Loc
: constant Source_Ptr
:= Sloc
(N
);
4666 X
: constant Node_Id
:= Prefix
(N
);
4667 Y
: constant Node_Id
:= First
(Expressions
(N
));
4670 X_Addr
, Y_Addr
: Node_Id
;
4671 -- the expressions for their integer addresses
4673 X_Size
, Y_Size
: Node_Id
;
4674 -- the expressions for their sizes
4679 -- Attribute expands into:
4681 -- if X'Address < Y'address then
4682 -- (X'address + X'Size - 1) >= Y'address
4684 -- (Y'address + Y'size - 1) >= X'Address
4687 -- with the proper address operations. We convert addresses to
4688 -- integer addresses to use predefined arithmetic. The size is
4689 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4690 -- to prevent the appearance of the same node in two places in
4694 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4695 Make_Attribute_Reference
(Loc
,
4696 Attribute_Name
=> Name_Address
,
4697 Prefix
=> New_Copy_Tree
(X
)));
4700 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4701 Make_Attribute_Reference
(Loc
,
4702 Attribute_Name
=> Name_Address
,
4703 Prefix
=> New_Copy_Tree
(Y
)));
4706 Make_Op_Divide
(Loc
,
4708 Make_Attribute_Reference
(Loc
,
4709 Attribute_Name
=> Name_Size
,
4710 Prefix
=> New_Copy_Tree
(X
)),
4712 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4715 Make_Op_Divide
(Loc
,
4717 Make_Attribute_Reference
(Loc
,
4718 Attribute_Name
=> Name_Size
,
4719 Prefix
=> New_Copy_Tree
(Y
)),
4721 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4725 Left_Opnd
=> X_Addr
,
4726 Right_Opnd
=> Y_Addr
);
4729 Make_If_Expression
(Loc
, New_List
(
4735 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
4737 Make_Op_Subtract
(Loc
,
4738 Left_Opnd
=> X_Size
,
4739 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4740 Right_Opnd
=> Y_Addr
),
4745 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
4747 Make_Op_Subtract
(Loc
,
4748 Left_Opnd
=> Y_Size
,
4749 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4750 Right_Opnd
=> X_Addr
))));
4752 Analyze_And_Resolve
(N
, Standard_Boolean
);
4753 end Overlaps_Storage
;
4759 when Attribute_Output
=> Output
: declare
4760 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4761 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4769 -- If no underlying type, we have an error that will be diagnosed
4770 -- elsewhere, so here we just completely ignore the expansion.
4776 -- Stream operations can appear in user code even if the restriction
4777 -- No_Streams is active (for example, when instantiating a predefined
4778 -- container). In that case rewrite the attribute as a Raise to
4779 -- prevent any run-time use.
4781 if Restriction_Active
(No_Streams
) then
4783 Make_Raise_Program_Error
(Sloc
(N
),
4784 Reason
=> PE_Stream_Operation_Not_Allowed
));
4785 Set_Etype
(N
, Standard_Void_Type
);
4789 -- If TSS for Output is present, just call it
4791 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
4793 if Present
(Pname
) then
4797 -- If there is a Stream_Convert pragma, use it, we rewrite
4799 -- sourcetyp'Output (stream, Item)
4803 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4805 -- where strmwrite is the given Write function that converts an
4806 -- argument of type sourcetyp or a type acctyp, from which it is
4807 -- derived to type strmtyp. The conversion to acttyp is required
4808 -- for the derived case.
4810 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4812 if Present
(Prag
) then
4814 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4815 Wfunc
:= Entity
(Expression
(Arg3
));
4818 Make_Attribute_Reference
(Loc
,
4819 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4820 Attribute_Name
=> Name_Output
,
4821 Expressions
=> New_List
(
4822 Relocate_Node
(First
(Exprs
)),
4823 Make_Function_Call
(Loc
,
4824 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4825 Parameter_Associations
=> New_List
(
4826 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4827 Relocate_Node
(Next
(First
(Exprs
)))))))));
4832 -- For elementary types, we call the W_xxx routine directly. Note
4833 -- that the effect of Write and Output is identical for the case
4834 -- of an elementary type (there are no discriminants or bounds).
4836 elsif Is_Elementary_Type
(U_Type
) then
4838 -- A special case arises if we have a defined _Write routine,
4839 -- since in this case we are required to call this routine.
4842 Typ
: Entity_Id
:= P_Type
;
4844 if Present
(Full_View
(Typ
)) then
4845 Typ
:= Full_View
(Typ
);
4848 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Write
)) then
4849 Build_Record_Or_Elementary_Output_Procedure
4850 (Loc
, Typ
, Decl
, Pname
);
4851 Insert_Action
(N
, Decl
);
4853 -- For normal cases, we call the W_xxx routine directly
4856 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4864 elsif Is_Array_Type
(U_Type
) then
4865 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4866 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4868 -- Class-wide case, first output external tag, then dispatch
4869 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4871 elsif Is_Class_Wide_Type
(P_Type
) then
4873 -- No need to do anything else compiling under restriction
4874 -- No_Dispatching_Calls. During the semantic analysis we
4875 -- already notified such violation.
4877 if Restriction_Active
(No_Dispatching_Calls
) then
4882 Strm
: constant Node_Id
:= First
(Exprs
);
4883 Item
: constant Node_Id
:= Next
(Strm
);
4886 -- Ada 2005 (AI-344): Check that the accessibility level
4887 -- of the type of the output object is not deeper than
4888 -- that of the attribute's prefix type.
4890 -- if Get_Access_Level (Item'Tag)
4891 -- /= Get_Access_Level (P_Type'Tag)
4896 -- String'Output (Strm, External_Tag (Item'Tag));
4898 -- We cannot figure out a practical way to implement this
4899 -- accessibility check on virtual machines, so we omit it.
4901 if Ada_Version
>= Ada_2005
4902 and then Tagged_Type_Expansion
4905 Make_Implicit_If_Statement
(N
,
4909 Build_Get_Access_Level
(Loc
,
4910 Make_Attribute_Reference
(Loc
,
4913 Duplicate_Subexpr
(Item
,
4915 Attribute_Name
=> Name_Tag
)),
4918 Make_Integer_Literal
(Loc
,
4919 Type_Access_Level
(P_Type
))),
4922 New_List
(Make_Raise_Statement
(Loc
,
4924 RTE
(RE_Tag_Error
), Loc
)))));
4928 Make_Attribute_Reference
(Loc
,
4929 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
4930 Attribute_Name
=> Name_Output
,
4931 Expressions
=> New_List
(
4932 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
4933 Make_Function_Call
(Loc
,
4935 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
4936 Parameter_Associations
=> New_List
(
4937 Make_Attribute_Reference
(Loc
,
4940 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
4941 Attribute_Name
=> Name_Tag
))))));
4944 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4946 -- Tagged type case, use the primitive Output function
4948 elsif Is_Tagged_Type
(U_Type
) then
4949 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4951 -- All other record type cases, including protected records.
4952 -- The latter only arise for expander generated code for
4953 -- handling shared passive partition access.
4957 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4959 -- Ada 2005 (AI-216): Program_Error is raised when executing
4960 -- the default implementation of the Output attribute of an
4961 -- unchecked union type if the type lacks default discriminant
4964 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4965 and then No
(Discriminant_Constraint
(U_Type
))
4968 Make_Raise_Program_Error
(Loc
,
4969 Reason
=> PE_Unchecked_Union_Restriction
));
4974 Build_Record_Or_Elementary_Output_Procedure
4975 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
4976 Insert_Action
(N
, Decl
);
4980 -- If we fall through, Pname is the name of the procedure to call
4982 Rewrite_Stream_Proc_Call
(Pname
);
4989 -- For enumeration types with a standard representation, Pos is
4990 -- handled by the back end.
4992 -- For enumeration types, with a non-standard representation we generate
4993 -- a call to the _Rep_To_Pos function created when the type was frozen.
4994 -- The call has the form
4996 -- _rep_to_pos (expr, flag)
4998 -- The parameter flag is True if range checks are enabled, causing
4999 -- Program_Error to be raised if the expression has an invalid
5000 -- representation, and False if range checks are suppressed.
5002 -- For integer types, Pos is equivalent to a simple integer
5003 -- conversion and we rewrite it as such
5005 when Attribute_Pos
=> Pos
: declare
5006 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
5009 -- Deal with zero/non-zero boolean values
5011 if Is_Boolean_Type
(Etyp
) then
5012 Adjust_Condition
(First
(Exprs
));
5013 Etyp
:= Standard_Boolean
;
5014 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5017 -- Case of enumeration type
5019 if Is_Enumeration_Type
(Etyp
) then
5021 -- Non-standard enumeration type (generate call)
5023 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5024 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5027 Make_Function_Call
(Loc
,
5029 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5030 Parameter_Associations
=> Exprs
)));
5032 Analyze_And_Resolve
(N
, Typ
);
5034 -- Standard enumeration type (do universal integer check)
5037 Apply_Universal_Integer_Attribute_Checks
(N
);
5040 -- Deal with integer types (replace by conversion)
5042 elsif Is_Integer_Type
(Etyp
) then
5043 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
5044 Analyze_And_Resolve
(N
, Typ
);
5053 -- We compute this if a component clause was present, otherwise we leave
5054 -- the computation up to the back end, since we don't know what layout
5057 when Attribute_Position
=> Position_Attr
: declare
5058 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5061 if Present
(Component_Clause
(CE
)) then
5063 -- In Ada 2005 (or later) if we have the non-default bit order,
5064 -- then we return the original value as given in the component
5065 -- clause (RM 2005 13.5.2(2/2)).
5067 if Ada_Version
>= Ada_2005
5068 and then Reverse_Bit_Order
(Scope
(CE
))
5071 Make_Integer_Literal
(Loc
,
5072 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
5074 -- Otherwise (Ada 83 or 95, or default bit order specified in
5075 -- later Ada version), return the normalized value.
5079 Make_Integer_Literal
(Loc
,
5080 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
5083 Analyze_And_Resolve
(N
, Typ
);
5085 -- If back end is doing things, just apply universal integer checks
5088 Apply_Universal_Integer_Attribute_Checks
(N
);
5096 -- 1. Deal with enumeration types with holes.
5097 -- 2. For floating-point, generate call to attribute function.
5098 -- 3. For other cases, deal with constraint checking.
5100 when Attribute_Pred
=> Pred
: declare
5101 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5105 -- For enumeration types with non-standard representations, we
5106 -- expand typ'Pred (x) into
5108 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5110 -- If the representation is contiguous, we compute instead
5111 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5112 -- The conversion function Enum_Pos_To_Rep is defined on the
5113 -- base type, not the subtype, so we have to use the base type
5114 -- explicitly for this and other enumeration attributes.
5116 if Is_Enumeration_Type
(Ptyp
)
5117 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5119 if Has_Contiguous_Rep
(Etyp
) then
5121 Unchecked_Convert_To
(Ptyp
,
5124 Make_Integer_Literal
(Loc
,
5125 Enumeration_Rep
(First_Literal
(Ptyp
))),
5127 Make_Function_Call
(Loc
,
5130 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5132 Parameter_Associations
=>
5134 Unchecked_Convert_To
(Ptyp
,
5135 Make_Op_Subtract
(Loc
,
5137 Unchecked_Convert_To
(Standard_Integer
,
5138 Relocate_Node
(First
(Exprs
))),
5140 Make_Integer_Literal
(Loc
, 1))),
5141 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5144 -- Add Boolean parameter True, to request program errror if
5145 -- we have a bad representation on our hands. If checks are
5146 -- suppressed, then add False instead
5148 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5150 Make_Indexed_Component
(Loc
,
5153 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5154 Expressions
=> New_List
(
5155 Make_Op_Subtract
(Loc
,
5157 Make_Function_Call
(Loc
,
5160 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5161 Parameter_Associations
=> Exprs
),
5162 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5165 Analyze_And_Resolve
(N
, Typ
);
5167 -- For floating-point, we transform 'Pred into a call to the Pred
5168 -- floating-point attribute function in Fat_xxx (xxx is root type).
5169 -- Note that this function takes care of the overflow case.
5171 elsif Is_Floating_Point_Type
(Ptyp
) then
5172 Expand_Fpt_Attribute_R
(N
);
5173 Analyze_And_Resolve
(N
, Typ
);
5175 -- For modular types, nothing to do (no overflow, since wraps)
5177 elsif Is_Modular_Integer_Type
(Ptyp
) then
5180 -- For other types, if argument is marked as needing a range check or
5181 -- overflow checking is enabled, we must generate a check.
5183 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5184 or else Do_Range_Check
(First
(Exprs
))
5186 Set_Do_Range_Check
(First
(Exprs
), False);
5187 Expand_Pred_Succ_Attribute
(N
);
5195 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5197 -- We rewrite X'Priority as the following run-time call:
5199 -- Get_Ceiling (X._Object)
5201 -- Note that although X'Priority is notionally an object, it is quite
5202 -- deliberately not defined as an aliased object in the RM. This means
5203 -- that it works fine to rewrite it as a call, without having to worry
5204 -- about complications that would other arise from X'Priority'Access,
5205 -- which is illegal, because of the lack of aliasing.
5207 when Attribute_Priority
=> Priority
: declare
5209 Conctyp
: Entity_Id
;
5210 New_Itype
: Entity_Id
;
5211 Object_Parm
: Node_Id
;
5213 RT_Subprg_Name
: Node_Id
;
5216 -- Look for the enclosing concurrent type
5218 Conctyp
:= Current_Scope
;
5219 while not Is_Concurrent_Type
(Conctyp
) loop
5220 Conctyp
:= Scope
(Conctyp
);
5223 pragma Assert
(Is_Protected_Type
(Conctyp
));
5225 -- Generate the actual of the call
5227 Subprg
:= Current_Scope
;
5228 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5229 Subprg
:= Scope
(Subprg
);
5232 -- Use of 'Priority inside protected entries and barriers (in both
5233 -- cases the type of the first formal of their expanded subprogram
5236 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5239 -- In the expansion of protected entries the type of the first
5240 -- formal of the Protected_Body_Subprogram is an Address. In order
5241 -- to reference the _object component we generate:
5243 -- type T is access p__ptTV;
5246 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5247 Set_Etype
(New_Itype
, New_Itype
);
5248 Set_Directly_Designated_Type
(New_Itype
,
5249 Corresponding_Record_Type
(Conctyp
));
5250 Freeze_Itype
(New_Itype
, N
);
5253 -- T!(O)._object'unchecked_access
5256 Make_Attribute_Reference
(Loc
,
5258 Make_Selected_Component
(Loc
,
5260 Unchecked_Convert_To
(New_Itype
,
5262 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5264 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5265 Attribute_Name
=> Name_Unchecked_Access
);
5267 -- Use of 'Priority inside a protected subprogram
5271 Make_Attribute_Reference
(Loc
,
5273 Make_Selected_Component
(Loc
,
5276 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5278 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5279 Attribute_Name
=> Name_Unchecked_Access
);
5282 -- Select the appropriate run-time subprogram
5284 if Number_Entries
(Conctyp
) = 0 then
5285 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5287 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5291 Make_Function_Call
(Loc
,
5292 Name
=> RT_Subprg_Name
,
5293 Parameter_Associations
=> New_List
(Object_Parm
));
5297 -- Avoid the generation of extra checks on the pointer to the
5298 -- protected object.
5300 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5307 when Attribute_Range_Length
=>
5309 -- The only special processing required is for the case where
5310 -- Range_Length is applied to an enumeration type with holes.
5311 -- In this case we transform
5317 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5319 -- So that the result reflects the proper Pos values instead
5320 -- of the underlying representations.
5322 if Is_Enumeration_Type
(Ptyp
)
5323 and then Has_Non_Standard_Rep
(Ptyp
)
5328 Make_Op_Subtract
(Loc
,
5330 Make_Attribute_Reference
(Loc
,
5331 Attribute_Name
=> Name_Pos
,
5332 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5333 Expressions
=> New_List
(
5334 Make_Attribute_Reference
(Loc
,
5335 Attribute_Name
=> Name_Last
,
5337 New_Occurrence_Of
(Ptyp
, Loc
)))),
5340 Make_Attribute_Reference
(Loc
,
5341 Attribute_Name
=> Name_Pos
,
5342 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5343 Expressions
=> New_List
(
5344 Make_Attribute_Reference
(Loc
,
5345 Attribute_Name
=> Name_First
,
5347 New_Occurrence_Of
(Ptyp
, Loc
))))),
5349 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5351 Analyze_And_Resolve
(N
, Typ
);
5353 -- For all other cases, the attribute is handled by the back end, but
5354 -- we need to deal with the case of the range check on a universal
5358 Apply_Universal_Integer_Attribute_Checks
(N
);
5365 when Attribute_Read
=> Read
: declare
5366 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5367 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
5368 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5378 -- If no underlying type, we have an error that will be diagnosed
5379 -- elsewhere, so here we just completely ignore the expansion.
5385 -- Stream operations can appear in user code even if the restriction
5386 -- No_Streams is active (for example, when instantiating a predefined
5387 -- container). In that case rewrite the attribute as a Raise to
5388 -- prevent any run-time use.
5390 if Restriction_Active
(No_Streams
) then
5392 Make_Raise_Program_Error
(Sloc
(N
),
5393 Reason
=> PE_Stream_Operation_Not_Allowed
));
5394 Set_Etype
(N
, B_Type
);
5398 -- The simple case, if there is a TSS for Read, just call it
5400 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
5402 if Present
(Pname
) then
5406 -- If there is a Stream_Convert pragma, use it, we rewrite
5408 -- sourcetyp'Read (stream, Item)
5412 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5414 -- where strmread is the given Read function that converts an
5415 -- argument of type strmtyp to type sourcetyp or a type from which
5416 -- it is derived. The conversion to sourcetyp is required in the
5419 -- A special case arises if Item is a type conversion in which
5420 -- case, we have to expand to:
5422 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5424 -- where Itemx is the expression of the type conversion (i.e.
5425 -- the actual object), and typex is the type of Itemx.
5427 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5429 if Present
(Prag
) then
5430 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
5431 Rfunc
:= Entity
(Expression
(Arg2
));
5432 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5434 OK_Convert_To
(B_Type
,
5435 Make_Function_Call
(Loc
,
5436 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
5437 Parameter_Associations
=> New_List
(
5438 Make_Attribute_Reference
(Loc
,
5441 (Etype
(First_Formal
(Rfunc
)), Loc
),
5442 Attribute_Name
=> Name_Input
,
5443 Expressions
=> New_List
(
5444 Relocate_Node
(First
(Exprs
)))))));
5446 if Nkind
(Lhs
) = N_Type_Conversion
then
5447 Lhs
:= Expression
(Lhs
);
5448 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5452 Make_Assignment_Statement
(Loc
,
5454 Expression
=> Rhs
));
5455 Set_Assignment_OK
(Lhs
);
5459 -- For elementary types, we call the I_xxx routine using the first
5460 -- parameter and then assign the result into the second parameter.
5461 -- We set Assignment_OK to deal with the conversion case.
5463 elsif Is_Elementary_Type
(U_Type
) then
5469 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5470 Rhs
:= Build_Elementary_Input_Call
(N
);
5472 if Nkind
(Lhs
) = N_Type_Conversion
then
5473 Lhs
:= Expression
(Lhs
);
5474 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5477 Set_Assignment_OK
(Lhs
);
5480 Make_Assignment_Statement
(Loc
,
5482 Expression
=> Rhs
));
5490 elsif Is_Array_Type
(U_Type
) then
5491 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
5492 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5494 -- Tagged type case, use the primitive Read function. Note that
5495 -- this will dispatch in the class-wide case which is what we want
5497 elsif Is_Tagged_Type
(U_Type
) then
5498 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
5500 -- All other record type cases, including protected records. The
5501 -- latter only arise for expander generated code for handling
5502 -- shared passive partition access.
5506 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5508 -- Ada 2005 (AI-216): Program_Error is raised when executing
5509 -- the default implementation of the Read attribute of an
5510 -- Unchecked_Union type. We replace the attribute with a
5511 -- raise statement (rather than inserting it before) to handle
5512 -- properly the case of an unchecked union that is a record
5515 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
5517 Make_Raise_Program_Error
(Loc
,
5518 Reason
=> PE_Unchecked_Union_Restriction
));
5519 Set_Etype
(N
, B_Type
);
5523 if Has_Discriminants
(U_Type
)
5525 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5527 Build_Mutable_Record_Read_Procedure
5528 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5530 Build_Record_Read_Procedure
5531 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5534 -- Suppress checks, uninitialized or otherwise invalid
5535 -- data does not cause constraint errors to be raised for
5536 -- a complete record read.
5538 Insert_Action
(N
, Decl
, All_Checks
);
5542 Rewrite_Stream_Proc_Call
(Pname
);
5549 -- Ref is identical to To_Address, see To_Address for processing
5555 -- Transforms 'Remainder into a call to the floating-point attribute
5556 -- function Remainder in Fat_xxx (where xxx is the root type)
5558 when Attribute_Remainder
=>
5559 Expand_Fpt_Attribute_RR
(N
);
5565 -- Transform 'Result into reference to _Result formal. At the point
5566 -- where a legal 'Result attribute is expanded, we know that we are in
5567 -- the context of a _Postcondition function with a _Result parameter.
5569 when Attribute_Result
=>
5570 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
5571 Analyze_And_Resolve
(N
, Typ
);
5577 -- The handling of the Round attribute is quite delicate. The processing
5578 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5579 -- semantics of Round, but we do not want anything to do with universal
5580 -- real at runtime, since this corresponds to using floating-point
5583 -- What we have now is that the Etype of the Round attribute correctly
5584 -- indicates the final result type. The operand of the Round is the
5585 -- conversion to universal real, described above, and the operand of
5586 -- this conversion is the actual operand of Round, which may be the
5587 -- special case of a fixed point multiplication or division (Etype =
5590 -- The exapander will expand first the operand of the conversion, then
5591 -- the conversion, and finally the round attribute itself, since we
5592 -- always work inside out. But we cannot simply process naively in this
5593 -- order. In the semantic world where universal fixed and real really
5594 -- exist and have infinite precision, there is no problem, but in the
5595 -- implementation world, where universal real is a floating-point type,
5596 -- we would get the wrong result.
5598 -- So the approach is as follows. First, when expanding a multiply or
5599 -- divide whose type is universal fixed, we do nothing at all, instead
5600 -- deferring the operation till later.
5602 -- The actual processing is done in Expand_N_Type_Conversion which
5603 -- handles the special case of Round by looking at its parent to see if
5604 -- it is a Round attribute, and if it is, handling the conversion (or
5605 -- its fixed multiply/divide child) in an appropriate manner.
5607 -- This means that by the time we get to expanding the Round attribute
5608 -- itself, the Round is nothing more than a type conversion (and will
5609 -- often be a null type conversion), so we just replace it with the
5610 -- appropriate conversion operation.
5612 when Attribute_Round
=>
5614 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
5615 Analyze_And_Resolve
(N
);
5621 -- Transforms 'Rounding into a call to the floating-point attribute
5622 -- function Rounding in Fat_xxx (where xxx is the root type)
5623 -- Expansion is avoided for cases the back end can handle directly.
5625 when Attribute_Rounding
=>
5626 if not Is_Inline_Floating_Point_Attribute
(N
) then
5627 Expand_Fpt_Attribute_R
(N
);
5634 -- Transforms 'Scaling into a call to the floating-point attribute
5635 -- function Scaling in Fat_xxx (where xxx is the root type)
5637 when Attribute_Scaling
=>
5638 Expand_Fpt_Attribute_RI
(N
);
5640 -------------------------
5641 -- Simple_Storage_Pool --
5642 -------------------------
5644 when Attribute_Simple_Storage_Pool
=>
5646 Make_Type_Conversion
(Loc
,
5647 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5648 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5649 Analyze_And_Resolve
(N
, Typ
);
5655 when Attribute_Object_Size
5657 | Attribute_Value_Size
5658 | Attribute_VADS_Size
5665 -- Processing for VADS_Size case. Note that this processing
5666 -- removes all traces of VADS_Size from the tree, and completes
5667 -- all required processing for VADS_Size by translating the
5668 -- attribute reference to an appropriate Size or Object_Size
5671 if Id
= Attribute_VADS_Size
5672 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5674 -- If the size is specified, then we simply use the specified
5675 -- size. This applies to both types and objects. The size of an
5676 -- object can be specified in the following ways:
5678 -- An explicit size object is given for an object
5679 -- A component size is specified for an indexed component
5680 -- A component clause is specified for a selected component
5681 -- The object is a component of a packed composite object
5683 -- If the size is specified, then VADS_Size of an object
5685 if (Is_Entity_Name
(Pref
)
5686 and then Present
(Size_Clause
(Entity
(Pref
))))
5688 (Nkind
(Pref
) = N_Component_Clause
5689 and then (Present
(Component_Clause
5690 (Entity
(Selector_Name
(Pref
))))
5691 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5693 (Nkind
(Pref
) = N_Indexed_Component
5694 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5695 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5697 Set_Attribute_Name
(N
, Name_Size
);
5699 -- Otherwise if we have an object rather than a type, then
5700 -- the VADS_Size attribute applies to the type of the object,
5701 -- rather than the object itself. This is one of the respects
5702 -- in which VADS_Size differs from Size.
5705 if (not Is_Entity_Name
(Pref
)
5706 or else not Is_Type
(Entity
(Pref
)))
5707 and then (Is_Scalar_Type
(Ptyp
)
5708 or else Is_Constrained
(Ptyp
))
5710 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
5713 -- For a scalar type for which no size was explicitly given,
5714 -- VADS_Size means Object_Size. This is the other respect in
5715 -- which VADS_Size differs from Size.
5717 if Is_Scalar_Type
(Ptyp
)
5718 and then No
(Size_Clause
(Ptyp
))
5720 Set_Attribute_Name
(N
, Name_Object_Size
);
5722 -- In all other cases, Size and VADS_Size are the sane
5725 Set_Attribute_Name
(N
, Name_Size
);
5730 -- If the prefix is X'Class, transform it into a direct reference
5731 -- to the class-wide type, because the back end must not see a
5732 -- 'Class reference.
5734 if Is_Entity_Name
(Pref
)
5735 and then Is_Class_Wide_Type
(Entity
(Pref
))
5737 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
5740 -- For X'Size applied to an object of a class-wide type, transform
5741 -- X'Size into a call to the primitive operation _Size applied to
5744 elsif Is_Class_Wide_Type
(Ptyp
) then
5746 -- No need to do anything else compiling under restriction
5747 -- No_Dispatching_Calls. During the semantic analysis we
5748 -- already noted this restriction violation.
5750 if Restriction_Active
(No_Dispatching_Calls
) then
5755 Make_Function_Call
(Loc
,
5757 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
5758 Parameter_Associations
=> New_List
(Pref
));
5760 if Typ
/= Standard_Long_Long_Integer
then
5762 -- The context is a specific integer type with which the
5763 -- original attribute was compatible. The function has a
5764 -- specific type as well, so to preserve the compatibility
5765 -- we must convert explicitly.
5767 New_Node
:= Convert_To
(Typ
, New_Node
);
5770 Rewrite
(N
, New_Node
);
5771 Analyze_And_Resolve
(N
, Typ
);
5774 -- Case of known RM_Size of a type
5776 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
5777 and then Is_Entity_Name
(Pref
)
5778 and then Is_Type
(Entity
(Pref
))
5779 and then Known_Static_RM_Size
(Entity
(Pref
))
5781 Siz
:= RM_Size
(Entity
(Pref
));
5783 -- Case of known Esize of a type
5785 elsif Id
= Attribute_Object_Size
5786 and then Is_Entity_Name
(Pref
)
5787 and then Is_Type
(Entity
(Pref
))
5788 and then Known_Static_Esize
(Entity
(Pref
))
5790 Siz
:= Esize
(Entity
(Pref
));
5792 -- Case of known size of object
5794 elsif Id
= Attribute_Size
5795 and then Is_Entity_Name
(Pref
)
5796 and then Is_Object
(Entity
(Pref
))
5797 and then Known_Esize
(Entity
(Pref
))
5798 and then Known_Static_Esize
(Entity
(Pref
))
5800 Siz
:= Esize
(Entity
(Pref
));
5802 -- For an array component, we can do Size in the front end if the
5803 -- component_size of the array is set.
5805 elsif Nkind
(Pref
) = N_Indexed_Component
then
5806 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
5808 -- For a record component, we can do Size in the front end if
5809 -- there is a component clause, or if the record is packed and the
5810 -- component's size is known at compile time.
5812 elsif Nkind
(Pref
) = N_Selected_Component
then
5814 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
5815 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5818 if Present
(Component_Clause
(Comp
)) then
5819 Siz
:= Esize
(Comp
);
5821 elsif Is_Packed
(Rec
) then
5822 Siz
:= RM_Size
(Ptyp
);
5825 Apply_Universal_Integer_Attribute_Checks
(N
);
5830 -- All other cases are handled by the back end
5833 Apply_Universal_Integer_Attribute_Checks
(N
);
5835 -- If Size is applied to a formal parameter that is of a packed
5836 -- array subtype, then apply Size to the actual subtype.
5838 if Is_Entity_Name
(Pref
)
5839 and then Is_Formal
(Entity
(Pref
))
5840 and then Is_Array_Type
(Ptyp
)
5841 and then Is_Packed
(Ptyp
)
5844 Make_Attribute_Reference
(Loc
,
5846 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
5847 Attribute_Name
=> Name_Size
));
5848 Analyze_And_Resolve
(N
, Typ
);
5851 -- If Size applies to a dereference of an access to
5852 -- unconstrained packed array, the back end needs to see its
5853 -- unconstrained nominal type, but also a hint to the actual
5854 -- constrained type.
5856 if Nkind
(Pref
) = N_Explicit_Dereference
5857 and then Is_Array_Type
(Ptyp
)
5858 and then not Is_Constrained
(Ptyp
)
5859 and then Is_Packed
(Ptyp
)
5861 Set_Actual_Designated_Subtype
(Pref
,
5862 Get_Actual_Subtype
(Pref
));
5868 -- Common processing for record and array component case
5870 if Siz
/= No_Uint
and then Siz
/= 0 then
5872 CS
: constant Boolean := Comes_From_Source
(N
);
5875 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
5877 -- This integer literal is not a static expression. We do
5878 -- not call Analyze_And_Resolve here, because this would
5879 -- activate the circuit for deciding that a static value
5880 -- was out of range, and we don't want that.
5882 -- So just manually set the type, mark the expression as
5883 -- non-static, and then ensure that the result is checked
5884 -- properly if the attribute comes from source (if it was
5885 -- internally generated, we never need a constraint check).
5888 Set_Is_Static_Expression
(N
, False);
5891 Apply_Constraint_Check
(N
, Typ
);
5901 when Attribute_Storage_Pool
=>
5903 Make_Type_Conversion
(Loc
,
5904 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5905 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5906 Analyze_And_Resolve
(N
, Typ
);
5912 when Attribute_Storage_Size
=> Storage_Size
: declare
5913 Alloc_Op
: Entity_Id
:= Empty
;
5917 -- Access type case, always go to the root type
5919 -- The case of access types results in a value of zero for the case
5920 -- where no storage size attribute clause has been given. If a
5921 -- storage size has been given, then the attribute is converted
5922 -- to a reference to the variable used to hold this value.
5924 if Is_Access_Type
(Ptyp
) then
5925 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
5927 Make_Attribute_Reference
(Loc
,
5928 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5929 Attribute_Name
=> Name_Max
,
5930 Expressions
=> New_List
(
5931 Make_Integer_Literal
(Loc
, 0),
5934 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
5936 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
5938 -- If the access type is associated with a simple storage pool
5939 -- object, then attempt to locate the optional Storage_Size
5940 -- function of the simple storage pool type. If not found,
5941 -- then the result will default to zero.
5943 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
5944 Name_Simple_Storage_Pool_Type
))
5947 Pool_Type
: constant Entity_Id
:=
5948 Base_Type
(Etype
(Entity
(N
)));
5951 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
5952 while Present
(Alloc_Op
) loop
5953 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
5954 and then Present
(First_Formal
(Alloc_Op
))
5955 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
5960 Alloc_Op
:= Homonym
(Alloc_Op
);
5964 -- In the normal Storage_Pool case, retrieve the primitive
5965 -- function associated with the pool type.
5970 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
5971 Attribute_Name
(N
));
5974 -- If Storage_Size wasn't found (can only occur in the simple
5975 -- storage pool case), then simply use zero for the result.
5977 if not Present
(Alloc_Op
) then
5978 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5980 -- Otherwise, rewrite the allocator as a call to pool type's
5981 -- Storage_Size function.
5986 Make_Function_Call
(Loc
,
5988 New_Occurrence_Of
(Alloc_Op
, Loc
),
5990 Parameter_Associations
=> New_List
(
5992 (Associated_Storage_Pool
5993 (Root_Type
(Ptyp
)), Loc
)))));
5997 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6000 Analyze_And_Resolve
(N
, Typ
);
6002 -- For tasks, we retrieve the size directly from the TCB. The
6003 -- size may depend on a discriminant of the type, and therefore
6004 -- can be a per-object expression, so type-level information is
6005 -- not sufficient in general. There are four cases to consider:
6007 -- a) If the attribute appears within a task body, the designated
6008 -- TCB is obtained by a call to Self.
6010 -- b) If the prefix of the attribute is the name of a task object,
6011 -- the designated TCB is the one stored in the corresponding record.
6013 -- c) If the prefix is a task type, the size is obtained from the
6014 -- size variable created for each task type
6016 -- d) If no Storage_Size was specified for the type, there is no
6017 -- size variable, and the value is a system-specific default.
6020 if In_Open_Scopes
(Ptyp
) then
6022 -- Storage_Size (Self)
6026 Make_Function_Call
(Loc
,
6028 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6029 Parameter_Associations
=>
6031 Make_Function_Call
(Loc
,
6033 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6035 elsif not Is_Entity_Name
(Pref
)
6036 or else not Is_Type
(Entity
(Pref
))
6038 -- Storage_Size (Rec (Obj).Size)
6042 Make_Function_Call
(Loc
,
6044 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6045 Parameter_Associations
=>
6047 Make_Selected_Component
(Loc
,
6049 Unchecked_Convert_To
(
6050 Corresponding_Record_Type
(Ptyp
),
6051 New_Copy_Tree
(Pref
)),
6053 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6055 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6057 -- Static Storage_Size pragma given for type: retrieve value
6058 -- from its allocated storage variable.
6062 Make_Function_Call
(Loc
,
6063 Name
=> New_Occurrence_Of
(
6064 RTE
(RE_Adjust_Storage_Size
), Loc
),
6065 Parameter_Associations
=>
6068 Storage_Size_Variable
(Ptyp
), Loc
)))));
6070 -- Get system default
6074 Make_Function_Call
(Loc
,
6077 RTE
(RE_Default_Stack_Size
), Loc
))));
6080 Analyze_And_Resolve
(N
, Typ
);
6088 when Attribute_Stream_Size
=>
6090 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6091 Analyze_And_Resolve
(N
, Typ
);
6097 -- 1. Deal with enumeration types with holes.
6098 -- 2. For floating-point, generate call to attribute function.
6099 -- 3. For other cases, deal with constraint checking.
6101 when Attribute_Succ
=> Succ
: declare
6102 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6105 -- For enumeration types with non-standard representations, we
6106 -- expand typ'Succ (x) into
6108 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6110 -- If the representation is contiguous, we compute instead
6111 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6113 if Is_Enumeration_Type
(Ptyp
)
6114 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6116 if Has_Contiguous_Rep
(Etyp
) then
6118 Unchecked_Convert_To
(Ptyp
,
6121 Make_Integer_Literal
(Loc
,
6122 Enumeration_Rep
(First_Literal
(Ptyp
))),
6124 Make_Function_Call
(Loc
,
6127 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6129 Parameter_Associations
=>
6131 Unchecked_Convert_To
(Ptyp
,
6134 Unchecked_Convert_To
(Standard_Integer
,
6135 Relocate_Node
(First
(Exprs
))),
6137 Make_Integer_Literal
(Loc
, 1))),
6138 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
6140 -- Add Boolean parameter True, to request program errror if
6141 -- we have a bad representation on our hands. Add False if
6142 -- checks are suppressed.
6144 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6146 Make_Indexed_Component
(Loc
,
6149 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6150 Expressions
=> New_List
(
6153 Make_Function_Call
(Loc
,
6156 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6157 Parameter_Associations
=> Exprs
),
6158 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6161 Analyze_And_Resolve
(N
, Typ
);
6163 -- For floating-point, we transform 'Succ into a call to the Succ
6164 -- floating-point attribute function in Fat_xxx (xxx is root type)
6166 elsif Is_Floating_Point_Type
(Ptyp
) then
6167 Expand_Fpt_Attribute_R
(N
);
6168 Analyze_And_Resolve
(N
, Typ
);
6170 -- For modular types, nothing to do (no overflow, since wraps)
6172 elsif Is_Modular_Integer_Type
(Ptyp
) then
6175 -- For other types, if argument is marked as needing a range check or
6176 -- overflow checking is enabled, we must generate a check.
6178 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6179 or else Do_Range_Check
(First
(Exprs
))
6181 Set_Do_Range_Check
(First
(Exprs
), False);
6182 Expand_Pred_Succ_Attribute
(N
);
6190 -- Transforms X'Tag into a direct reference to the tag of X
6192 when Attribute_Tag
=> Tag
: declare
6194 Prefix_Is_Type
: Boolean;
6197 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6198 Ttyp
:= Entity
(Pref
);
6199 Prefix_Is_Type
:= True;
6202 Prefix_Is_Type
:= False;
6205 if Is_Class_Wide_Type
(Ttyp
) then
6206 Ttyp
:= Root_Type
(Ttyp
);
6209 Ttyp
:= Underlying_Type
(Ttyp
);
6211 -- Ada 2005: The type may be a synchronized tagged type, in which
6212 -- case the tag information is stored in the corresponding record.
6214 if Is_Concurrent_Type
(Ttyp
) then
6215 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6218 if Prefix_Is_Type
then
6220 -- For VMs we leave the type attribute unexpanded because
6221 -- there's not a dispatching table to reference.
6223 if Tagged_Type_Expansion
then
6225 Unchecked_Convert_To
(RTE
(RE_Tag
),
6227 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6228 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6231 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6232 -- references the primary tag of the actual object. If 'Tag is
6233 -- applied to class-wide interface objects we generate code that
6234 -- displaces "this" to reference the base of the object.
6236 elsif Comes_From_Source
(N
)
6237 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6238 and then Is_Interface
(Etype
(Prefix
(N
)))
6241 -- (To_Tag_Ptr (Prefix'Address)).all
6243 -- Note that Prefix'Address is recursively expanded into a call
6244 -- to Base_Address (Obj.Tag)
6246 -- Not needed for VM targets, since all handled by the VM
6248 if Tagged_Type_Expansion
then
6250 Make_Explicit_Dereference
(Loc
,
6251 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6252 Make_Attribute_Reference
(Loc
,
6253 Prefix
=> Relocate_Node
(Pref
),
6254 Attribute_Name
=> Name_Address
))));
6255 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6260 Make_Selected_Component
(Loc
,
6261 Prefix
=> Relocate_Node
(Pref
),
6263 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6264 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6272 -- Transforms 'Terminated attribute into a call to Terminated function
6274 when Attribute_Terminated
=> Terminated
: begin
6276 -- The prefix of Terminated is of a task interface class-wide type.
6278 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6280 if Ada_Version
>= Ada_2005
6281 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6282 and then Is_Interface
(Ptyp
)
6283 and then Is_Task_Interface
(Ptyp
)
6286 Make_Function_Call
(Loc
,
6288 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6289 Parameter_Associations
=> New_List
(
6290 Make_Unchecked_Type_Conversion
(Loc
,
6292 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6293 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
6295 elsif Restricted_Profile
then
6297 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6301 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6304 Analyze_And_Resolve
(N
, Standard_Boolean
);
6311 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6312 -- unchecked conversion from (integral) type of X to type address.
6315 | Attribute_To_Address
6318 Unchecked_Convert_To
(RTE
(RE_Address
),
6319 Relocate_Node
(First
(Exprs
))));
6320 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6326 when Attribute_To_Any
=> To_Any
: declare
6327 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6328 Decls
: constant List_Id
:= New_List
;
6334 Relocate_Node
(First
(Exprs
))), Decls
));
6335 Insert_Actions
(N
, Decls
);
6336 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6343 -- Transforms 'Truncation into a call to the floating-point attribute
6344 -- function Truncation in Fat_xxx (where xxx is the root type).
6345 -- Expansion is avoided for cases the back end can handle directly.
6347 when Attribute_Truncation
=>
6348 if not Is_Inline_Floating_Point_Attribute
(N
) then
6349 Expand_Fpt_Attribute_R
(N
);
6356 when Attribute_TypeCode
=> TypeCode
: declare
6357 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6358 Decls
: constant List_Id
:= New_List
;
6360 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
6361 Insert_Actions
(N
, Decls
);
6362 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6365 -----------------------
6366 -- Unbiased_Rounding --
6367 -----------------------
6369 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6370 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6371 -- root type). Expansion is avoided for cases the back end can handle
6374 when Attribute_Unbiased_Rounding
=>
6375 if not Is_Inline_Floating_Point_Attribute
(N
) then
6376 Expand_Fpt_Attribute_R
(N
);
6383 when Attribute_Update
=>
6384 Expand_Update_Attribute
(N
);
6390 -- The processing for VADS_Size is shared with Size
6396 -- For enumeration types with a standard representation, and for all
6397 -- other types, Val is handled by the back end. For enumeration types
6398 -- with a non-standard representation we use the _Pos_To_Rep array that
6399 -- was created when the type was frozen.
6401 when Attribute_Val
=> Val
: declare
6402 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
6405 if Is_Enumeration_Type
(Etyp
)
6406 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6408 if Has_Contiguous_Rep
(Etyp
) then
6410 Rep_Node
: constant Node_Id
:=
6411 Unchecked_Convert_To
(Etyp
,
6414 Make_Integer_Literal
(Loc
,
6415 Enumeration_Rep
(First_Literal
(Etyp
))),
6417 (Convert_To
(Standard_Integer
,
6418 Relocate_Node
(First
(Exprs
))))));
6422 Unchecked_Convert_To
(Etyp
,
6425 Make_Integer_Literal
(Loc
,
6426 Enumeration_Rep
(First_Literal
(Etyp
))),
6428 Make_Function_Call
(Loc
,
6431 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6432 Parameter_Associations
=> New_List
(
6434 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
6439 Make_Indexed_Component
(Loc
,
6440 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
6441 Expressions
=> New_List
(
6442 Convert_To
(Standard_Integer
,
6443 Relocate_Node
(First
(Exprs
))))));
6446 Analyze_And_Resolve
(N
, Typ
);
6448 -- If the argument is marked as requiring a range check then generate
6451 elsif Do_Range_Check
(First
(Exprs
)) then
6452 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
6460 -- The code for valid is dependent on the particular types involved.
6461 -- See separate sections below for the generated code in each case.
6463 when Attribute_Valid
=> Valid
: declare
6464 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
6467 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
6468 -- Save the validity checking mode. We always turn off validity
6469 -- checking during process of 'Valid since this is one place
6470 -- where we do not want the implicit validity checks to intefere
6471 -- with the explicit validity check that the programmer is doing.
6473 function Make_Range_Test
return Node_Id
;
6474 -- Build the code for a range test of the form
6475 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6477 ---------------------
6478 -- Make_Range_Test --
6479 ---------------------
6481 function Make_Range_Test
return Node_Id
is
6485 -- The prefix of attribute 'Valid should always denote an object
6486 -- reference. The reference is either coming directly from source
6487 -- or is produced by validity check expansion.
6489 -- If the prefix denotes a variable which captures the value of
6490 -- an object for validation purposes, use the variable in the
6491 -- range test. This ensures that no extra copies or extra reads
6492 -- are produced as part of the test. Generate:
6494 -- Temp : ... := Object;
6495 -- if not Temp in ... then
6497 if Is_Validation_Variable_Reference
(Pref
) then
6498 Temp
:= New_Occurrence_Of
(Entity
(Pref
), Loc
);
6500 -- Otherwise the prefix is either a source object or a constant
6501 -- produced by validity check expansion. Generate:
6503 -- Temp : constant ... := Pref;
6504 -- if not Temp in ... then
6507 Temp
:= Duplicate_Subexpr
(Pref
);
6512 Left_Opnd
=> Unchecked_Convert_To
(Btyp
, Temp
),
6516 Unchecked_Convert_To
(Btyp
,
6517 Make_Attribute_Reference
(Loc
,
6518 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6519 Attribute_Name
=> Name_First
)),
6521 Unchecked_Convert_To
(Btyp
,
6522 Make_Attribute_Reference
(Loc
,
6523 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6524 Attribute_Name
=> Name_Last
))));
6525 end Make_Range_Test
;
6527 -- Start of processing for Attribute_Valid
6530 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6531 -- will be handled by the back-end directly.
6533 if CodePeer_Mode
and then Comes_From_Source
(N
) then
6537 -- Turn off validity checks. We do not want any implicit validity
6538 -- checks to intefere with the explicit check from the attribute
6540 Validity_Checks_On
:= False;
6542 -- Retrieve the base type. Handle the case where the base type is a
6543 -- private enumeration type.
6545 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
6546 Btyp
:= Full_View
(Btyp
);
6549 -- Floating-point case. This case is handled by the Valid attribute
6550 -- code in the floating-point attribute run-time library.
6552 if Is_Floating_Point_Type
(Ptyp
) then
6553 Float_Valid
: declare
6557 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
6558 -- Return entity for Pkg.Nam
6560 --------------------
6561 -- Get_Fat_Entity --
6562 --------------------
6564 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
6565 Exp_Name
: constant Node_Id
:=
6566 Make_Selected_Component
(Loc
,
6567 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
6568 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
6570 Find_Selected_Component
(Exp_Name
);
6571 return Entity
(Exp_Name
);
6574 -- Start of processing for Float_Valid
6577 -- The C and AAMP back-ends handle Valid for fpt types
6579 if Modify_Tree_For_C
or else Float_Rep
(Btyp
) = AAMP
then
6580 Analyze_And_Resolve
(Pref
, Ptyp
);
6581 Set_Etype
(N
, Standard_Boolean
);
6585 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6587 -- If the prefix is a reverse SSO component, or is possibly
6588 -- unaligned, first create a temporary copy that is in
6589 -- native SSO, and properly aligned. Make it Volatile to
6590 -- prevent folding in the back-end. Note that we use an
6591 -- intermediate constrained string type to initialize the
6592 -- temporary, as the value at hand might be invalid, and in
6593 -- that case it cannot be copied using a floating point
6596 if In_Reverse_Storage_Order_Object
(Pref
)
6597 or else Is_Possibly_Unaligned_Object
(Pref
)
6600 Temp
: constant Entity_Id
:=
6601 Make_Temporary
(Loc
, 'F');
6603 Fat_S
: constant Entity_Id
:=
6604 Get_Fat_Entity
(Name_S
);
6605 -- Constrained string subtype of appropriate size
6607 Fat_P
: constant Entity_Id
:=
6608 Get_Fat_Entity
(Name_P
);
6611 Decl
: constant Node_Id
:=
6612 Make_Object_Declaration
(Loc
,
6613 Defining_Identifier
=> Temp
,
6614 Aliased_Present
=> True,
6615 Object_Definition
=>
6616 New_Occurrence_Of
(Ptyp
, Loc
));
6619 Set_Aspect_Specifications
(Decl
, New_List
(
6620 Make_Aspect_Specification
(Loc
,
6622 Make_Identifier
(Loc
, Name_Volatile
))));
6628 Make_Assignment_Statement
(Loc
,
6630 Make_Explicit_Dereference
(Loc
,
6632 Unchecked_Convert_To
(Fat_P
,
6633 Make_Attribute_Reference
(Loc
,
6635 New_Occurrence_Of
(Temp
, Loc
),
6637 Name_Unrestricted_Access
))),
6639 Unchecked_Convert_To
(Fat_S
,
6640 Relocate_Node
(Pref
)))),
6642 Suppress
=> All_Checks
);
6644 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
6648 -- We now have an object of the proper endianness and
6649 -- alignment, and can construct a Valid attribute.
6651 -- We make sure the prefix of this valid attribute is
6652 -- marked as not coming from source, to avoid losing
6653 -- warnings from 'Valid looking like a possible update.
6655 Set_Comes_From_Source
(Pref
, False);
6657 Expand_Fpt_Attribute
6658 (N
, Pkg
, Name_Valid
,
6660 Make_Attribute_Reference
(Loc
,
6661 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6662 Attribute_Name
=> Name_Unrestricted_Access
)));
6665 -- One more task, we still need a range check. Required
6666 -- only if we have a constraint, since the Valid routine
6667 -- catches infinities properly (infinities are never valid).
6669 -- The way we do the range check is simply to create the
6670 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6672 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
6675 Left_Opnd
=> Relocate_Node
(N
),
6678 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
6679 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6683 -- Enumeration type with holes
6685 -- For enumeration types with holes, the Pos value constructed by
6686 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6687 -- second argument of False returns minus one for an invalid value,
6688 -- and the non-negative pos value for a valid value, so the
6689 -- expansion of X'Valid is simply:
6691 -- type(X)'Pos (X) >= 0
6693 -- We can't quite generate it that way because of the requirement
6694 -- for the non-standard second argument of False in the resulting
6695 -- rep_to_pos call, so we have to explicitly create:
6697 -- _rep_to_pos (X, False) >= 0
6699 -- If we have an enumeration subtype, we also check that the
6700 -- value is in range:
6702 -- _rep_to_pos (X, False) >= 0
6704 -- (X >= type(X)'First and then type(X)'Last <= X)
6706 elsif Is_Enumeration_Type
(Ptyp
)
6707 and then Present
(Enum_Pos_To_Rep
(Btyp
))
6712 Make_Function_Call
(Loc
,
6714 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
6715 Parameter_Associations
=> New_List
(
6717 New_Occurrence_Of
(Standard_False
, Loc
))),
6718 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
6722 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
6724 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
6726 -- The call to Make_Range_Test will create declarations
6727 -- that need a proper insertion point, but Pref is now
6728 -- attached to a node with no ancestor. Attach to tree
6729 -- even if it is to be rewritten below.
6731 Set_Parent
(Tst
, Parent
(N
));
6735 Left_Opnd
=> Make_Range_Test
,
6741 -- Fortran convention booleans
6743 -- For the very special case of Fortran convention booleans, the
6744 -- value is always valid, since it is an integer with the semantics
6745 -- that non-zero is true, and any value is permissible.
6747 elsif Is_Boolean_Type
(Ptyp
)
6748 and then Convention
(Ptyp
) = Convention_Fortran
6750 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6752 -- For biased representations, we will be doing an unchecked
6753 -- conversion without unbiasing the result. That means that the range
6754 -- test has to take this into account, and the proper form of the
6757 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6759 elsif Has_Biased_Representation
(Ptyp
) then
6760 Btyp
:= RTE
(RE_Unsigned_32
);
6764 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
6766 Unchecked_Convert_To
(Btyp
,
6767 Make_Attribute_Reference
(Loc
,
6768 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6769 Attribute_Name
=> Name_Range_Length
))));
6771 -- For all other scalar types, what we want logically is a
6774 -- X in type(X)'First .. type(X)'Last
6776 -- But that's precisely what won't work because of possible
6777 -- unwanted optimization (and indeed the basic motivation for
6778 -- the Valid attribute is exactly that this test does not work).
6779 -- What will work is:
6781 -- Btyp!(X) >= Btyp!(type(X)'First)
6783 -- Btyp!(X) <= Btyp!(type(X)'Last)
6785 -- where Btyp is an integer type large enough to cover the full
6786 -- range of possible stored values (i.e. it is chosen on the basis
6787 -- of the size of the type, not the range of the values). We write
6788 -- this as two tests, rather than a range check, so that static
6789 -- evaluation will easily remove either or both of the checks if
6790 -- they can be -statically determined to be true (this happens
6791 -- when the type of X is static and the range extends to the full
6792 -- range of stored values).
6794 -- Unsigned types. Note: it is safe to consider only whether the
6795 -- subtype is unsigned, since we will in that case be doing all
6796 -- unsigned comparisons based on the subtype range. Since we use the
6797 -- actual subtype object size, this is appropriate.
6799 -- For example, if we have
6801 -- subtype x is integer range 1 .. 200;
6802 -- for x'Object_Size use 8;
6804 -- Now the base type is signed, but objects of this type are bits
6805 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6806 -- correct, even though a value greater than 127 looks signed to a
6807 -- signed comparison.
6809 elsif Is_Unsigned_Type
(Ptyp
) then
6810 if Esize
(Ptyp
) <= 32 then
6811 Btyp
:= RTE
(RE_Unsigned_32
);
6813 Btyp
:= RTE
(RE_Unsigned_64
);
6816 Rewrite
(N
, Make_Range_Test
);
6821 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6822 Btyp
:= Standard_Integer
;
6824 Btyp
:= Universal_Integer
;
6827 Rewrite
(N
, Make_Range_Test
);
6830 -- If a predicate is present, then we do the predicate test, even if
6831 -- within the predicate function (infinite recursion is warned about
6832 -- in Sem_Attr in that case).
6835 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6838 if Present
(Pred_Func
) then
6841 Left_Opnd
=> Relocate_Node
(N
),
6842 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6846 Analyze_And_Resolve
(N
, Standard_Boolean
);
6847 Validity_Checks_On
:= Save_Validity_Checks_On
;
6854 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6858 if Present
(Underlying_Type
(Ptyp
)) then
6859 Ftyp
:= Underlying_Type
(Ptyp
);
6864 -- Replace by True if no scalar parts
6866 if not Scalar_Part_Present
(Ftyp
) then
6867 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6869 -- For scalar types, Valid_Scalars is the same as Valid
6871 elsif Is_Scalar_Type
(Ftyp
) then
6873 Make_Attribute_Reference
(Loc
,
6874 Attribute_Name
=> Name_Valid
,
6877 -- For array types, we construct a function that determines if there
6878 -- are any non-valid scalar subcomponents, and call the function.
6879 -- We only do this for arrays whose component type needs checking
6881 elsif Is_Array_Type
(Ftyp
)
6882 and then Scalar_Part_Present
(Component_Type
(Ftyp
))
6885 Make_Function_Call
(Loc
,
6887 New_Occurrence_Of
(Build_Array_VS_Func
(Ftyp
, N
), Loc
),
6888 Parameter_Associations
=> New_List
(Pref
)));
6890 -- For record types, we construct a function that determines if there
6891 -- are any non-valid scalar subcomponents, and call the function.
6893 elsif Is_Record_Type
(Ftyp
)
6894 and then Nkind
(Type_Definition
(Declaration_Node
(Ftyp
))) =
6898 Make_Function_Call
(Loc
,
6900 New_Occurrence_Of
(Build_Record_VS_Func
(Ftyp
, N
), Loc
),
6901 Parameter_Associations
=> New_List
(Pref
)));
6903 -- Other record types or types with discriminants
6905 elsif Is_Record_Type
(Ftyp
) or else Has_Discriminants
(Ptyp
) then
6907 -- Build expression with list of equality tests
6915 X
:= New_Occurrence_Of
(Standard_True
, Loc
);
6916 C
:= First_Component_Or_Discriminant
(Ptyp
);
6917 while Present
(C
) loop
6918 if not Scalar_Part_Present
(Etype
(C
)) then
6920 elsif Is_Scalar_Type
(Etype
(C
)) then
6923 A
:= Name_Valid_Scalars
;
6930 Make_Attribute_Reference
(Loc
,
6931 Attribute_Name
=> A
,
6933 Make_Selected_Component
(Loc
,
6935 Duplicate_Subexpr
(Pref
, Name_Req
=> True),
6937 New_Occurrence_Of
(C
, Loc
))));
6939 Next_Component_Or_Discriminant
(C
);
6945 -- For all other types, result is True
6948 Rewrite
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
6951 -- Result is always boolean, but never static
6953 Analyze_And_Resolve
(N
, Standard_Boolean
);
6954 Set_Is_Static_Expression
(N
, False);
6961 -- Value attribute is handled in separate unit Exp_Imgv
6963 when Attribute_Value
=>
6964 Exp_Imgv
.Expand_Value_Attribute
(N
);
6970 -- The processing for Value_Size shares the processing for Size
6976 -- The processing for Version shares the processing for Body_Version
6982 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6984 when Attribute_Wide_Image
=>
6986 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
6987 -- back-end knows how to handle this attribute directly.
6989 if CodePeer_Mode
then
6993 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
6995 ---------------------
6996 -- Wide_Wide_Image --
6997 ---------------------
6999 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7001 when Attribute_Wide_Wide_Image
=>
7003 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7004 -- back-end knows how to handle this attribute directly.
7006 if CodePeer_Mode
then
7010 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7016 -- We expand typ'Wide_Value (X) into
7019 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7021 -- Wide_String_To_String is a runtime function that converts its wide
7022 -- string argument to String, converting any non-translatable characters
7023 -- into appropriate escape sequences. This preserves the required
7024 -- semantics of Wide_Value in all cases, and results in a very simple
7025 -- implementation approach.
7027 -- Note: for this approach to be fully standard compliant for the cases
7028 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7029 -- method must cover the entire character range (e.g. UTF-8). But that
7030 -- is a reasonable requirement when dealing with encoded character
7031 -- sequences. Presumably if one of the restrictive encoding mechanisms
7032 -- is in use such as Shift-JIS, then characters that cannot be
7033 -- represented using this encoding will not appear in any case.
7035 when Attribute_Wide_Value
=>
7037 Make_Attribute_Reference
(Loc
,
7039 Attribute_Name
=> Name_Value
,
7041 Expressions
=> New_List
(
7042 Make_Function_Call
(Loc
,
7044 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7046 Parameter_Associations
=> New_List
(
7047 Relocate_Node
(First
(Exprs
)),
7048 Make_Integer_Literal
(Loc
,
7049 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7051 Analyze_And_Resolve
(N
, Typ
);
7053 ---------------------
7054 -- Wide_Wide_Value --
7055 ---------------------
7057 -- We expand typ'Wide_Value_Value (X) into
7060 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7062 -- Wide_Wide_String_To_String is a runtime function that converts its
7063 -- wide string argument to String, converting any non-translatable
7064 -- characters into appropriate escape sequences. This preserves the
7065 -- required semantics of Wide_Wide_Value in all cases, and results in a
7066 -- very simple implementation approach.
7068 -- It's not quite right where typ = Wide_Wide_Character, because the
7069 -- encoding method may not cover the whole character type ???
7071 when Attribute_Wide_Wide_Value
=>
7073 Make_Attribute_Reference
(Loc
,
7075 Attribute_Name
=> Name_Value
,
7077 Expressions
=> New_List
(
7078 Make_Function_Call
(Loc
,
7081 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7083 Parameter_Associations
=> New_List
(
7084 Relocate_Node
(First
(Exprs
)),
7085 Make_Integer_Literal
(Loc
,
7086 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7088 Analyze_And_Resolve
(N
, Typ
);
7090 ---------------------
7091 -- Wide_Wide_Width --
7092 ---------------------
7094 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7096 when Attribute_Wide_Wide_Width
=>
7097 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7103 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7105 when Attribute_Wide_Width
=>
7106 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7112 -- Width attribute is handled in separate unit Exp_Imgv
7114 when Attribute_Width
=>
7115 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7121 when Attribute_Write
=> Write
: declare
7122 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7123 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7131 -- If no underlying type, we have an error that will be diagnosed
7132 -- elsewhere, so here we just completely ignore the expansion.
7138 -- Stream operations can appear in user code even if the restriction
7139 -- No_Streams is active (for example, when instantiating a predefined
7140 -- container). In that case rewrite the attribute as a Raise to
7141 -- prevent any run-time use.
7143 if Restriction_Active
(No_Streams
) then
7145 Make_Raise_Program_Error
(Sloc
(N
),
7146 Reason
=> PE_Stream_Operation_Not_Allowed
));
7147 Set_Etype
(N
, U_Type
);
7151 -- The simple case, if there is a TSS for Write, just call it
7153 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7155 if Present
(Pname
) then
7159 -- If there is a Stream_Convert pragma, use it, we rewrite
7161 -- sourcetyp'Output (stream, Item)
7165 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7167 -- where strmwrite is the given Write function that converts an
7168 -- argument of type sourcetyp or a type acctyp, from which it is
7169 -- derived to type strmtyp. The conversion to acttyp is required
7170 -- for the derived case.
7172 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7174 if Present
(Prag
) then
7176 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7177 Wfunc
:= Entity
(Expression
(Arg3
));
7180 Make_Attribute_Reference
(Loc
,
7181 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7182 Attribute_Name
=> Name_Output
,
7183 Expressions
=> New_List
(
7184 Relocate_Node
(First
(Exprs
)),
7185 Make_Function_Call
(Loc
,
7186 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7187 Parameter_Associations
=> New_List
(
7188 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7189 Relocate_Node
(Next
(First
(Exprs
)))))))));
7194 -- For elementary types, we call the W_xxx routine directly
7196 elsif Is_Elementary_Type
(U_Type
) then
7197 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7203 elsif Is_Array_Type
(U_Type
) then
7204 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7205 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
7207 -- Tagged type case, use the primitive Write function. Note that
7208 -- this will dispatch in the class-wide case which is what we want
7210 elsif Is_Tagged_Type
(U_Type
) then
7211 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7213 -- All other record type cases, including protected records.
7214 -- The latter only arise for expander generated code for
7215 -- handling shared passive partition access.
7219 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7221 -- Ada 2005 (AI-216): Program_Error is raised when executing
7222 -- the default implementation of the Write attribute of an
7223 -- Unchecked_Union type. However, if the 'Write reference is
7224 -- within the generated Output stream procedure, Write outputs
7225 -- the components, and the default values of the discriminant
7226 -- are streamed by the Output procedure itself. If there are
7227 -- no default values this is also erroneous.
7229 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
7230 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7231 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
7232 or else No
(Discriminant_Default_Value
7233 (First_Discriminant
(U_Type
)))
7236 Make_Raise_Program_Error
(Loc
,
7237 Reason
=> PE_Unchecked_Union_Restriction
));
7238 Set_Etype
(N
, U_Type
);
7243 if Has_Discriminants
(U_Type
)
7245 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
7247 Build_Mutable_Record_Write_Procedure
7248 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7250 Build_Record_Write_Procedure
7251 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7254 Insert_Action
(N
, Decl
);
7258 -- If we fall through, Pname is the procedure to be called
7260 Rewrite_Stream_Proc_Call
(Pname
);
7263 -- Component_Size is handled by the back end, unless the component size
7264 -- is known at compile time, which is always true in the packed array
7265 -- case. It is important that the packed array case is handled in the
7266 -- front end (see Eval_Attribute) since the back end would otherwise get
7267 -- confused by the equivalent packed array type.
7269 when Attribute_Component_Size
=>
7272 -- The following attributes are handled by the back end (except that
7273 -- static cases have already been evaluated during semantic processing,
7274 -- but in any case the back end should not count on this).
7276 -- The back end also handles the non-class-wide cases of Size
7278 when Attribute_Bit_Order
7279 | Attribute_Code_Address
7280 | Attribute_Definite
7282 | Attribute_Null_Parameter
7283 | Attribute_Passed_By_Reference
7284 | Attribute_Pool_Address
7285 | Attribute_Scalar_Storage_Order
7289 -- The following attributes are also handled by the back end, but return
7290 -- a universal integer result, so may need a conversion for checking
7291 -- that the result is in range.
7294 | Attribute_Max_Alignment_For_Allocation
7296 Apply_Universal_Integer_Attribute_Checks
(N
);
7298 -- The following attributes should not appear at this stage, since they
7299 -- have already been handled by the analyzer (and properly rewritten
7300 -- with corresponding values or entities to represent the right values)
7302 when Attribute_Abort_Signal
7303 | Attribute_Address_Size
7304 | Attribute_Atomic_Always_Lock_Free
7307 | Attribute_Compiler_Version
7308 | Attribute_Default_Bit_Order
7309 | Attribute_Default_Scalar_Storage_Order
7316 | Attribute_Fast_Math
7317 | Attribute_First_Valid
7318 | Attribute_Has_Access_Values
7319 | Attribute_Has_Discriminants
7320 | Attribute_Has_Tagged_Values
7322 | Attribute_Last_Valid
7323 | Attribute_Library_Level
7324 | Attribute_Lock_Free
7325 | Attribute_Machine_Emax
7326 | Attribute_Machine_Emin
7327 | Attribute_Machine_Mantissa
7328 | Attribute_Machine_Overflows
7329 | Attribute_Machine_Radix
7330 | Attribute_Machine_Rounds
7331 | Attribute_Maximum_Alignment
7332 | Attribute_Model_Emin
7333 | Attribute_Model_Epsilon
7334 | Attribute_Model_Mantissa
7335 | Attribute_Model_Small
7337 | Attribute_Partition_ID
7339 | Attribute_Restriction_Set
7340 | Attribute_Safe_Emax
7341 | Attribute_Safe_First
7342 | Attribute_Safe_Large
7343 | Attribute_Safe_Last
7344 | Attribute_Safe_Small
7346 | Attribute_Signed_Zeros
7348 | Attribute_Storage_Unit
7349 | Attribute_Stub_Type
7350 | Attribute_System_Allocator_Alignment
7351 | Attribute_Target_Name
7352 | Attribute_Type_Class
7353 | Attribute_Type_Key
7354 | Attribute_Unconstrained_Array
7355 | Attribute_Universal_Literal_String
7356 | Attribute_Wchar_T_Size
7357 | Attribute_Word_Size
7359 raise Program_Error
;
7361 -- The Asm_Input and Asm_Output attributes are not expanded at this
7362 -- stage, but will be eliminated in the expansion of the Asm call, see
7363 -- Exp_Intr for details. So the back end will never see these either.
7365 when Attribute_Asm_Input
7366 | Attribute_Asm_Output
7371 -- Note: as mentioned earlier, individual sections of the above case
7372 -- statement assume there is no code after the case statement, and are
7373 -- legitimately allowed to execute return statements if they have nothing
7374 -- more to do, so DO NOT add code at this point.
7377 when RE_Not_Available
=>
7379 end Expand_N_Attribute_Reference
;
7381 --------------------------------
7382 -- Expand_Pred_Succ_Attribute --
7383 --------------------------------
7385 -- For typ'Pred (exp), we generate the check
7387 -- [constraint_error when exp = typ'Base'First]
7389 -- Similarly, for typ'Succ (exp), we generate the check
7391 -- [constraint_error when exp = typ'Base'Last]
7393 -- These checks are not generated for modular types, since the proper
7394 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7395 -- We also suppress these checks if we are the right side of an assignment
7396 -- statement or the expression of an object declaration, where the flag
7397 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7399 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
7400 Loc
: constant Source_Ptr
:= Sloc
(N
);
7401 P
: constant Node_Id
:= Parent
(N
);
7405 if Attribute_Name
(N
) = Name_Pred
then
7411 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
7412 or else not Suppress_Assignment_Checks
(P
)
7415 Make_Raise_Constraint_Error
(Loc
,
7419 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
7421 Make_Attribute_Reference
(Loc
,
7423 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
7424 Attribute_Name
=> Cnam
)),
7425 Reason
=> CE_Overflow_Check_Failed
));
7427 end Expand_Pred_Succ_Attribute
;
7429 -----------------------------
7430 -- Expand_Update_Attribute --
7431 -----------------------------
7433 procedure Expand_Update_Attribute
(N
: Node_Id
) is
7434 procedure Process_Component_Or_Element_Update
7439 -- Generate the statements necessary to update a single component or an
7440 -- element of the prefix. The code is inserted before the attribute N.
7441 -- Temp denotes the entity of the anonymous object created to reflect
7442 -- the changes in values. Comp is the component/index expression to be
7443 -- updated. Expr is an expression yielding the new value of Comp. Typ
7444 -- is the type of the prefix of attribute Update.
7446 procedure Process_Range_Update
7451 -- Generate the statements necessary to update a slice of the prefix.
7452 -- The code is inserted before the attribute N. Temp denotes the entity
7453 -- of the anonymous object created to reflect the changes in values.
7454 -- Comp is range of the slice to be updated. Expr is an expression
7455 -- yielding the new value of Comp. Typ is the type of the prefix of
7456 -- attribute Update.
7458 -----------------------------------------
7459 -- Process_Component_Or_Element_Update --
7460 -----------------------------------------
7462 procedure Process_Component_Or_Element_Update
7468 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7473 -- An array element may be modified by the following relations
7474 -- depending on the number of dimensions:
7476 -- 1 => Expr -- one dimensional update
7477 -- (1, ..., N) => Expr -- multi dimensional update
7479 -- The above forms are converted in assignment statements where the
7480 -- left hand side is an indexed component:
7482 -- Temp (1) := Expr; -- one dimensional update
7483 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7485 if Is_Array_Type
(Typ
) then
7487 -- The index expressions of a multi dimensional array update
7488 -- appear as an aggregate.
7490 if Nkind
(Comp
) = N_Aggregate
then
7491 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
7493 Exprs
:= New_List
(Relocate_Node
(Comp
));
7497 Make_Indexed_Component
(Loc
,
7498 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7499 Expressions
=> Exprs
);
7501 -- A record component update appears in the following form:
7505 -- The above relation is transformed into an assignment statement
7506 -- where the left hand side is a selected component:
7508 -- Temp.Comp := Expr;
7510 else pragma Assert
(Is_Record_Type
(Typ
));
7512 Make_Selected_Component
(Loc
,
7513 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7514 Selector_Name
=> Relocate_Node
(Comp
));
7518 Make_Assignment_Statement
(Loc
,
7520 Expression
=> Relocate_Node
(Expr
)));
7521 end Process_Component_Or_Element_Update
;
7523 --------------------------
7524 -- Process_Range_Update --
7525 --------------------------
7527 procedure Process_Range_Update
7533 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
7534 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7538 -- A range update appears as
7540 -- (Low .. High => Expr)
7542 -- The above construct is transformed into a loop that iterates over
7543 -- the given range and modifies the corresponding array values to the
7546 -- for Index in Low .. High loop
7547 -- Temp (<Index_Typ> (Index)) := Expr;
7550 Index
:= Make_Temporary
(Loc
, 'I');
7553 Make_Loop_Statement
(Loc
,
7555 Make_Iteration_Scheme
(Loc
,
7556 Loop_Parameter_Specification
=>
7557 Make_Loop_Parameter_Specification
(Loc
,
7558 Defining_Identifier
=> Index
,
7559 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
7561 Statements
=> New_List
(
7562 Make_Assignment_Statement
(Loc
,
7564 Make_Indexed_Component
(Loc
,
7565 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7566 Expressions
=> New_List
(
7567 Convert_To
(Index_Typ
,
7568 New_Occurrence_Of
(Index
, Loc
)))),
7569 Expression
=> Relocate_Node
(Expr
))),
7571 End_Label
=> Empty
));
7572 end Process_Range_Update
;
7576 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
7577 Loc
: constant Source_Ptr
:= Sloc
(N
);
7578 Pref
: constant Node_Id
:= Prefix
(N
);
7579 Typ
: constant Entity_Id
:= Etype
(Pref
);
7582 CW_Temp
: Entity_Id
;
7587 -- Start of processing for Expand_Update_Attribute
7590 -- Create the anonymous object to store the value of the prefix and
7591 -- capture subsequent changes in value.
7593 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
7595 -- Preserve the tag of the prefix by offering a specific view of the
7596 -- class-wide version of the prefix.
7598 if Is_Tagged_Type
(Typ
) then
7601 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7603 CW_Temp
:= Make_Temporary
(Loc
, 'T');
7604 CW_Typ
:= Class_Wide_Type
(Typ
);
7607 Make_Object_Declaration
(Loc
,
7608 Defining_Identifier
=> CW_Temp
,
7609 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
7611 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
7614 -- Temp : Typ renames Typ (CW_Temp);
7617 Make_Object_Renaming_Declaration
(Loc
,
7618 Defining_Identifier
=> Temp
,
7619 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
7621 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
7627 -- Temp : Typ := Pref;
7630 Make_Object_Declaration
(Loc
,
7631 Defining_Identifier
=> Temp
,
7632 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7633 Expression
=> Relocate_Node
(Pref
)));
7636 -- Process the update aggregate
7638 Assoc
:= First
(Component_Associations
(Aggr
));
7639 while Present
(Assoc
) loop
7640 Comp
:= First
(Choices
(Assoc
));
7641 Expr
:= Expression
(Assoc
);
7642 while Present
(Comp
) loop
7643 if Nkind
(Comp
) = N_Range
then
7644 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
7646 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
7655 -- The attribute is replaced by a reference to the anonymous object
7657 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7659 end Expand_Update_Attribute
;
7665 procedure Find_Fat_Info
7667 Fat_Type
: out Entity_Id
;
7668 Fat_Pkg
: out RE_Id
)
7670 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
7673 -- All we do is use the root type (historically this dealt with
7674 -- VAX-float .. to be cleaned up further later ???)
7678 if Fat_Type
= Standard_Short_Float
then
7679 Fat_Pkg
:= RE_Attr_Short_Float
;
7681 elsif Fat_Type
= Standard_Float
then
7682 Fat_Pkg
:= RE_Attr_Float
;
7684 elsif Fat_Type
= Standard_Long_Float
then
7685 Fat_Pkg
:= RE_Attr_Long_Float
;
7687 elsif Fat_Type
= Standard_Long_Long_Float
then
7688 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7690 -- Universal real (which is its own root type) is treated as being
7691 -- equivalent to Standard.Long_Long_Float, since it is defined to
7692 -- have the same precision as the longest Float type.
7694 elsif Fat_Type
= Universal_Real
then
7695 Fat_Type
:= Standard_Long_Long_Float
;
7696 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7699 raise Program_Error
;
7703 ----------------------------
7704 -- Find_Stream_Subprogram --
7705 ----------------------------
7707 function Find_Stream_Subprogram
7709 Nam
: TSS_Name_Type
) return Entity_Id
7711 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7712 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
7714 function Is_Available
(Entity
: RE_Id
) return Boolean;
7715 pragma Inline
(Is_Available
);
7716 -- Function to check whether the specified run-time call is available
7717 -- in the run time used. In the case of a configurable run time, it
7718 -- is normal that some subprograms are not there.
7720 -- I don't understand this routine at all, why is this not just a
7721 -- call to RTE_Available? And if for some reason we need a different
7722 -- routine with different semantics, why is not in Rtsfind ???
7728 function Is_Available
(Entity
: RE_Id
) return Boolean is
7730 -- Assume that the unit will always be available when using a
7731 -- "normal" (not configurable) run time.
7733 return not Configurable_Run_Time_Mode
or else RTE_Available
(Entity
);
7736 -- Start of processing for Find_Stream_Subprogram
7739 if Present
(Ent
) then
7743 -- Stream attributes for strings are expanded into library calls. The
7744 -- following checks are disabled when the run-time is not available or
7745 -- when compiling predefined types due to bootstrap issues. As a result,
7746 -- the compiler will generate in-place stream routines for string types
7747 -- that appear in GNAT's library, but will generate calls via rtsfind
7748 -- to library routines for user code.
7750 -- Note: In the case of using a configurable run time, it is very likely
7751 -- that stream routines for string types are not present (they require
7752 -- file system support). In this case, the specific stream routines for
7753 -- strings are not used, relying on the regular stream mechanism
7754 -- instead. That is why we include the test Is_Available when dealing
7755 -- with these cases.
7757 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
7758 -- Storage_Array as defined in package System.Storage_Elements
7760 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
7762 -- Case of No_Stream_Optimizations restriction active
7764 if Restriction_Active
(No_Stream_Optimizations
) then
7765 if Nam
= TSS_Stream_Input
7766 and then Is_Available
(RE_Storage_Array_Input
)
7768 return RTE
(RE_Storage_Array_Input
);
7770 elsif Nam
= TSS_Stream_Output
7771 and then Is_Available
(RE_Storage_Array_Output
)
7773 return RTE
(RE_Storage_Array_Output
);
7775 elsif Nam
= TSS_Stream_Read
7776 and then Is_Available
(RE_Storage_Array_Read
)
7778 return RTE
(RE_Storage_Array_Read
);
7780 elsif Nam
= TSS_Stream_Write
7781 and then Is_Available
(RE_Storage_Array_Write
)
7783 return RTE
(RE_Storage_Array_Write
);
7785 elsif Nam
/= TSS_Stream_Input
and then
7786 Nam
/= TSS_Stream_Output
and then
7787 Nam
/= TSS_Stream_Read
and then
7788 Nam
/= TSS_Stream_Write
7790 raise Program_Error
;
7793 -- Restriction No_Stream_Optimizations is not set, so we can go
7794 -- ahead and optimize using the block IO forms of the routines.
7797 if Nam
= TSS_Stream_Input
7798 and then Is_Available
(RE_Storage_Array_Input_Blk_IO
)
7800 return RTE
(RE_Storage_Array_Input_Blk_IO
);
7802 elsif Nam
= TSS_Stream_Output
7803 and then Is_Available
(RE_Storage_Array_Output_Blk_IO
)
7805 return RTE
(RE_Storage_Array_Output_Blk_IO
);
7807 elsif Nam
= TSS_Stream_Read
7808 and then Is_Available
(RE_Storage_Array_Read_Blk_IO
)
7810 return RTE
(RE_Storage_Array_Read_Blk_IO
);
7812 elsif Nam
= TSS_Stream_Write
7813 and then Is_Available
(RE_Storage_Array_Write_Blk_IO
)
7815 return RTE
(RE_Storage_Array_Write_Blk_IO
);
7817 elsif Nam
/= TSS_Stream_Input
and then
7818 Nam
/= TSS_Stream_Output
and then
7819 Nam
/= TSS_Stream_Read
and then
7820 Nam
/= TSS_Stream_Write
7822 raise Program_Error
;
7826 -- Stream_Element_Array as defined in package Ada.Streams
7828 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
7830 -- Case of No_Stream_Optimizations restriction active
7832 if Restriction_Active
(No_Stream_Optimizations
) then
7833 if Nam
= TSS_Stream_Input
7834 and then Is_Available
(RE_Stream_Element_Array_Input
)
7836 return RTE
(RE_Stream_Element_Array_Input
);
7838 elsif Nam
= TSS_Stream_Output
7839 and then Is_Available
(RE_Stream_Element_Array_Output
)
7841 return RTE
(RE_Stream_Element_Array_Output
);
7843 elsif Nam
= TSS_Stream_Read
7844 and then Is_Available
(RE_Stream_Element_Array_Read
)
7846 return RTE
(RE_Stream_Element_Array_Read
);
7848 elsif Nam
= TSS_Stream_Write
7849 and then Is_Available
(RE_Stream_Element_Array_Write
)
7851 return RTE
(RE_Stream_Element_Array_Write
);
7853 elsif Nam
/= TSS_Stream_Input
and then
7854 Nam
/= TSS_Stream_Output
and then
7855 Nam
/= TSS_Stream_Read
and then
7856 Nam
/= TSS_Stream_Write
7858 raise Program_Error
;
7861 -- Restriction No_Stream_Optimizations is not set, so we can go
7862 -- ahead and optimize using the block IO forms of the routines.
7865 if Nam
= TSS_Stream_Input
7866 and then Is_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
7868 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
7870 elsif Nam
= TSS_Stream_Output
7871 and then Is_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
7873 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
7875 elsif Nam
= TSS_Stream_Read
7876 and then Is_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
7878 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
7880 elsif Nam
= TSS_Stream_Write
7881 and then Is_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
7883 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
7885 elsif Nam
/= TSS_Stream_Input
and then
7886 Nam
/= TSS_Stream_Output
and then
7887 Nam
/= TSS_Stream_Read
and then
7888 Nam
/= TSS_Stream_Write
7890 raise Program_Error
;
7894 -- String as defined in package Ada
7896 elsif Base_Typ
= Standard_String
then
7898 -- Case of No_Stream_Optimizations restriction active
7900 if Restriction_Active
(No_Stream_Optimizations
) then
7901 if Nam
= TSS_Stream_Input
7902 and then Is_Available
(RE_String_Input
)
7904 return RTE
(RE_String_Input
);
7906 elsif Nam
= TSS_Stream_Output
7907 and then Is_Available
(RE_String_Output
)
7909 return RTE
(RE_String_Output
);
7911 elsif Nam
= TSS_Stream_Read
7912 and then Is_Available
(RE_String_Read
)
7914 return RTE
(RE_String_Read
);
7916 elsif Nam
= TSS_Stream_Write
7917 and then Is_Available
(RE_String_Write
)
7919 return RTE
(RE_String_Write
);
7921 elsif Nam
/= TSS_Stream_Input
and then
7922 Nam
/= TSS_Stream_Output
and then
7923 Nam
/= TSS_Stream_Read
and then
7924 Nam
/= TSS_Stream_Write
7926 raise Program_Error
;
7929 -- Restriction No_Stream_Optimizations is not set, so we can go
7930 -- ahead and optimize using the block IO forms of the routines.
7933 if Nam
= TSS_Stream_Input
7934 and then Is_Available
(RE_String_Input_Blk_IO
)
7936 return RTE
(RE_String_Input_Blk_IO
);
7938 elsif Nam
= TSS_Stream_Output
7939 and then Is_Available
(RE_String_Output_Blk_IO
)
7941 return RTE
(RE_String_Output_Blk_IO
);
7943 elsif Nam
= TSS_Stream_Read
7944 and then Is_Available
(RE_String_Read_Blk_IO
)
7946 return RTE
(RE_String_Read_Blk_IO
);
7948 elsif Nam
= TSS_Stream_Write
7949 and then Is_Available
(RE_String_Write_Blk_IO
)
7951 return RTE
(RE_String_Write_Blk_IO
);
7953 elsif Nam
/= TSS_Stream_Input
and then
7954 Nam
/= TSS_Stream_Output
and then
7955 Nam
/= TSS_Stream_Read
and then
7956 Nam
/= TSS_Stream_Write
7958 raise Program_Error
;
7962 -- Wide_String as defined in package Ada
7964 elsif Base_Typ
= Standard_Wide_String
then
7966 -- Case of No_Stream_Optimizations restriction active
7968 if Restriction_Active
(No_Stream_Optimizations
) then
7969 if Nam
= TSS_Stream_Input
7970 and then Is_Available
(RE_Wide_String_Input
)
7972 return RTE
(RE_Wide_String_Input
);
7974 elsif Nam
= TSS_Stream_Output
7975 and then Is_Available
(RE_Wide_String_Output
)
7977 return RTE
(RE_Wide_String_Output
);
7979 elsif Nam
= TSS_Stream_Read
7980 and then Is_Available
(RE_Wide_String_Read
)
7982 return RTE
(RE_Wide_String_Read
);
7984 elsif Nam
= TSS_Stream_Write
7985 and then Is_Available
(RE_Wide_String_Write
)
7987 return RTE
(RE_Wide_String_Write
);
7989 elsif Nam
/= TSS_Stream_Input
and then
7990 Nam
/= TSS_Stream_Output
and then
7991 Nam
/= TSS_Stream_Read
and then
7992 Nam
/= TSS_Stream_Write
7994 raise Program_Error
;
7997 -- Restriction No_Stream_Optimizations is not set, so we can go
7998 -- ahead and optimize using the block IO forms of the routines.
8001 if Nam
= TSS_Stream_Input
8002 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
8004 return RTE
(RE_Wide_String_Input_Blk_IO
);
8006 elsif Nam
= TSS_Stream_Output
8007 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
8009 return RTE
(RE_Wide_String_Output_Blk_IO
);
8011 elsif Nam
= TSS_Stream_Read
8012 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
8014 return RTE
(RE_Wide_String_Read_Blk_IO
);
8016 elsif Nam
= TSS_Stream_Write
8017 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
8019 return RTE
(RE_Wide_String_Write_Blk_IO
);
8021 elsif Nam
/= TSS_Stream_Input
and then
8022 Nam
/= TSS_Stream_Output
and then
8023 Nam
/= TSS_Stream_Read
and then
8024 Nam
/= TSS_Stream_Write
8026 raise Program_Error
;
8030 -- Wide_Wide_String as defined in package Ada
8032 elsif Base_Typ
= Standard_Wide_Wide_String
then
8034 -- Case of No_Stream_Optimizations restriction active
8036 if Restriction_Active
(No_Stream_Optimizations
) then
8037 if Nam
= TSS_Stream_Input
8038 and then Is_Available
(RE_Wide_Wide_String_Input
)
8040 return RTE
(RE_Wide_Wide_String_Input
);
8042 elsif Nam
= TSS_Stream_Output
8043 and then Is_Available
(RE_Wide_Wide_String_Output
)
8045 return RTE
(RE_Wide_Wide_String_Output
);
8047 elsif Nam
= TSS_Stream_Read
8048 and then Is_Available
(RE_Wide_Wide_String_Read
)
8050 return RTE
(RE_Wide_Wide_String_Read
);
8052 elsif Nam
= TSS_Stream_Write
8053 and then Is_Available
(RE_Wide_Wide_String_Write
)
8055 return RTE
(RE_Wide_Wide_String_Write
);
8057 elsif Nam
/= TSS_Stream_Input
and then
8058 Nam
/= TSS_Stream_Output
and then
8059 Nam
/= TSS_Stream_Read
and then
8060 Nam
/= TSS_Stream_Write
8062 raise Program_Error
;
8065 -- Restriction No_Stream_Optimizations is not set, so we can go
8066 -- ahead and optimize using the block IO forms of the routines.
8069 if Nam
= TSS_Stream_Input
8070 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8072 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8074 elsif Nam
= TSS_Stream_Output
8075 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8077 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8079 elsif Nam
= TSS_Stream_Read
8080 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8082 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8084 elsif Nam
= TSS_Stream_Write
8085 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8087 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8089 elsif Nam
/= TSS_Stream_Input
and then
8090 Nam
/= TSS_Stream_Output
and then
8091 Nam
/= TSS_Stream_Read
and then
8092 Nam
/= TSS_Stream_Write
8094 raise Program_Error
;
8100 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8101 return Find_Prim_Op
(Typ
, Nam
);
8103 return Find_Inherited_TSS
(Typ
, Nam
);
8105 end Find_Stream_Subprogram
;
8111 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8115 BT
:= Base_Type
(T
);
8117 if Is_Private_Type
(BT
)
8118 and then Present
(Full_View
(BT
))
8120 BT
:= Full_View
(BT
);
8126 -----------------------
8127 -- Get_Index_Subtype --
8128 -----------------------
8130 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
8131 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
8136 if Is_Access_Type
(P_Type
) then
8137 P_Type
:= Designated_Type
(P_Type
);
8140 if No
(Expressions
(N
)) then
8143 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
8146 Indx
:= First_Index
(P_Type
);
8152 return Etype
(Indx
);
8153 end Get_Index_Subtype
;
8155 -------------------------------
8156 -- Get_Stream_Convert_Pragma --
8157 -------------------------------
8159 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8164 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8165 -- that a stream convert pragma for a tagged type is not inherited from
8166 -- its parent. Probably what is wrong here is that it is basically
8167 -- incorrect to consider a stream convert pragma to be a representation
8168 -- pragma at all ???
8170 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8171 while Present
(N
) loop
8172 if Nkind
(N
) = N_Pragma
8173 and then Pragma_Name
(N
) = Name_Stream_Convert
8175 -- For tagged types this pragma is not inherited, so we
8176 -- must verify that it is defined for the given type and
8180 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8182 if not Is_Tagged_Type
(T
)
8184 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8194 end Get_Stream_Convert_Pragma
;
8196 ---------------------------------
8197 -- Is_Constrained_Packed_Array --
8198 ---------------------------------
8200 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8201 Arr
: Entity_Id
:= Typ
;
8204 if Is_Access_Type
(Arr
) then
8205 Arr
:= Designated_Type
(Arr
);
8208 return Is_Array_Type
(Arr
)
8209 and then Is_Constrained
(Arr
)
8210 and then Present
(Packed_Array_Impl_Type
(Arr
));
8211 end Is_Constrained_Packed_Array
;
8213 ----------------------------------------
8214 -- Is_Inline_Floating_Point_Attribute --
8215 ----------------------------------------
8217 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8218 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8220 function Is_GCC_Target
return Boolean;
8221 -- Return True if we are using a GCC target/back-end
8222 -- ??? Note: the implementation is kludgy/fragile
8228 function Is_GCC_Target
return Boolean is
8230 return not CodePeer_Mode
8231 and then not AAMP_On_Target
8232 and then not Modify_Tree_For_C
;
8235 -- Start of processing for Is_Inline_Floating_Point_Attribute
8238 -- Machine and Model can be expanded by the GCC and AAMP back ends only
8240 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8241 return Is_GCC_Target
or else AAMP_On_Target
;
8243 -- Remaining cases handled by all back ends are Rounding and Truncation
8244 -- when appearing as the operand of a conversion to some integer type.
8246 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8247 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8252 -- Here we are in the integer conversion context
8254 -- Very probably we should also recognize the cases of Machine_Rounding
8255 -- and unbiased rounding in this conversion context, but the back end is
8256 -- not yet prepared to handle these cases ???
8258 return Id
= Attribute_Rounding
or else Id
= Attribute_Truncation
;
8259 end Is_Inline_Floating_Point_Attribute
;