1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Fname
; use Fname
;
43 with Freeze
; use Freeze
;
44 with Gnatvsn
; use Gnatvsn
;
45 with Itypes
; use Itypes
;
47 with Namet
; use Namet
;
48 with Nmake
; use Nmake
;
49 with Nlists
; use Nlists
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 with Sinfo
; use Sinfo
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Targparm
; use Targparm
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uintp
; use Uintp
;
70 with Uname
; use Uname
;
71 with Validsw
; use Validsw
;
73 package body Exp_Attr
is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 function Build_Array_VS_Func
81 Nod
: Node_Id
) return Entity_Id
;
82 -- Build function to test Valid_Scalars for array type A_Type. Nod is the
83 -- Valid_Scalars attribute node, used to insert the function body, and the
84 -- value returned is the entity of the constructed function body. We do not
85 -- bother to generate a separate spec for this subprogram.
87 function Build_Record_VS_Func
89 Nod
: Node_Id
) return Entity_Id
;
90 -- Build function to test Valid_Scalars for record type A_Type. Nod is the
91 -- Valid_Scalars attribute node, used to insert the function body, and the
92 -- value returned is the entity of the constructed function body. We do not
93 -- bother to generate a separate spec for this subprogram.
95 procedure Compile_Stream_Body_In_Scope
100 -- The body for a stream subprogram may be generated outside of the scope
101 -- of the type. If the type is fully private, it may depend on the full
102 -- view of other types (e.g. indexes) that are currently private as well.
103 -- We install the declarations of the package in which the type is declared
104 -- before compiling the body in what is its proper environment. The Check
105 -- parameter indicates if checks are to be suppressed for the stream body.
106 -- We suppress checks for array/record reads, since the rule is that these
107 -- are like assignments, out of range values due to uninitialized storage,
108 -- or other invalid values do NOT cause a Constraint_Error to be raised.
109 -- If we are within an instance body all visibility has been established
110 -- already and there is no need to install the package.
112 -- This mechanism is now extended to the component types of the array type,
113 -- when the component type is not in scope and is private, to handle
114 -- properly the case when the full view has defaulted discriminants.
116 -- This special processing is ultimately caused by the fact that the
117 -- compiler lacks a well-defined phase when full views are visible
118 -- everywhere. Having such a separate pass would remove much of the
119 -- special-case code that shuffles partial and full views in the middle
120 -- of semantic analysis and expansion.
122 procedure Expand_Access_To_Protected_Op
126 -- An attribute reference to a protected subprogram is transformed into
127 -- a pair of pointers: one to the object, and one to the operations.
128 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
130 procedure Expand_Fpt_Attribute
135 -- This procedure expands a call to a floating-point attribute function.
136 -- N is the attribute reference node, and Args is a list of arguments to
137 -- be passed to the function call. Pkg identifies the package containing
138 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
139 -- have already been converted to the floating-point type for which Pkg was
140 -- instantiated. The Nam argument is the relevant attribute processing
141 -- routine to be called. This is the same as the attribute name, except in
142 -- the Unaligned_Valid case.
144 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
145 -- This procedure expands a call to a floating-point attribute function
146 -- that takes a single floating-point argument. The function to be called
147 -- is always the same as the attribute name.
149 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
150 -- This procedure expands a call to a floating-point attribute function
151 -- that takes one floating-point argument and one integer argument. The
152 -- function to be called is always the same as the attribute name.
154 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
155 -- This procedure expands a call to a floating-point attribute function
156 -- that takes two floating-point arguments. The function to be called
157 -- is always the same as the attribute name.
159 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
160 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
161 -- loop may be converted into a conditional block. See body for details.
163 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
164 -- Handle the expansion of attributes 'Max and 'Min, including expanding
165 -- then out if we are in Modify_Tree_For_C mode.
167 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
168 -- Handles expansion of Pred or Succ attributes for case of non-real
169 -- operand with overflow checking required.
171 procedure Expand_Update_Attribute
(N
: Node_Id
);
172 -- Handle the expansion of attribute Update
174 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
175 -- Used for Last, Last, and Length, when the prefix is an array type.
176 -- Obtains the corresponding index subtype.
178 procedure Find_Fat_Info
180 Fat_Type
: out Entity_Id
;
181 Fat_Pkg
: out RE_Id
);
182 -- Given a floating-point type T, identifies the package containing the
183 -- attributes for this type (returned in Fat_Pkg), and the corresponding
184 -- type for which this package was instantiated from Fat_Gen. Error if T
185 -- is not a floating-point type.
187 function Find_Stream_Subprogram
189 Nam
: TSS_Name_Type
) return Entity_Id
;
190 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
191 -- types, the corresponding primitive operation is looked up, else the
192 -- appropriate TSS from the type itself, or from its closest ancestor
193 -- defining it, is returned. In both cases, inheritance of representation
194 -- aspects is thus taken into account.
196 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
197 -- The stream functions need to examine the underlying representation of
198 -- composite types. In some cases T may be non-private but its base type
199 -- is, in which case the function returns the corresponding full view.
201 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
202 -- Given a type, find a corresponding stream convert pragma that applies to
203 -- the implementation base type of this type (Typ). If found, return the
204 -- pragma node, otherwise return Empty if no pragma is found.
206 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
207 -- Utility for array attributes, returns true on packed constrained
208 -- arrays, and on access to same.
210 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
211 -- Returns true iff the given node refers to an attribute call that
212 -- can be expanded directly by the back end and does not need front end
213 -- expansion. Typically used for rounding and truncation attributes that
214 -- appear directly inside a conversion to integer.
216 -------------------------
217 -- Build_Array_VS_Func --
218 -------------------------
220 function Build_Array_VS_Func
222 Nod
: Node_Id
) return Entity_Id
224 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
225 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
226 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
227 Body_Stmts
: List_Id
;
228 Index_List
: List_Id
;
231 function Test_Component
return List_Id
;
232 -- Create one statement to test validity of one component designated by
233 -- a full set of indexes. Returns statement list containing test.
235 function Test_One_Dimension
(N
: Int
) return List_Id
;
236 -- Create loop to test one dimension of the array. The single statement
237 -- in the loop body tests the inner dimensions if any, or else the
238 -- single component. Note that this procedure is called recursively,
239 -- with N being the dimension to be initialized. A call with N greater
240 -- than the number of dimensions simply generates the component test,
241 -- terminating the recursion. Returns statement list containing tests.
247 function Test_Component
return List_Id
is
253 Make_Indexed_Component
(Loc
,
254 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
255 Expressions
=> Index_List
);
257 if Is_Scalar_Type
(Comp_Type
) then
260 Anam
:= Name_Valid_Scalars
;
264 Make_If_Statement
(Loc
,
268 Make_Attribute_Reference
(Loc
,
269 Attribute_Name
=> Anam
,
271 Then_Statements
=> New_List
(
272 Make_Simple_Return_Statement
(Loc
,
273 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
276 ------------------------
277 -- Test_One_Dimension --
278 ------------------------
280 function Test_One_Dimension
(N
: Int
) return List_Id
is
284 -- If all dimensions dealt with, we simply test the component
286 if N
> Number_Dimensions
(A_Type
) then
287 return Test_Component
;
289 -- Here we generate the required loop
293 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
295 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
298 Make_Implicit_Loop_Statement
(Nod
,
301 Make_Iteration_Scheme
(Loc
,
302 Loop_Parameter_Specification
=>
303 Make_Loop_Parameter_Specification
(Loc
,
304 Defining_Identifier
=> Index
,
305 Discrete_Subtype_Definition
=>
306 Make_Attribute_Reference
(Loc
,
307 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
308 Attribute_Name
=> Name_Range
,
309 Expressions
=> New_List
(
310 Make_Integer_Literal
(Loc
, N
))))),
311 Statements
=> Test_One_Dimension
(N
+ 1)),
312 Make_Simple_Return_Statement
(Loc
,
313 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
315 end Test_One_Dimension
;
317 -- Start of processing for Build_Array_VS_Func
320 Index_List
:= New_List
;
321 Body_Stmts
:= Test_One_Dimension
(1);
323 -- Parameter is always (A : A_Typ)
325 Formals
:= New_List
(
326 Make_Parameter_Specification
(Loc
,
327 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uA
),
329 Out_Present
=> False,
330 Parameter_Type
=> New_Occurrence_Of
(A_Type
, Loc
)));
334 Set_Ekind
(Func_Id
, E_Function
);
335 Set_Is_Internal
(Func_Id
);
338 Make_Subprogram_Body
(Loc
,
340 Make_Function_Specification
(Loc
,
341 Defining_Unit_Name
=> Func_Id
,
342 Parameter_Specifications
=> Formals
,
344 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
345 Declarations
=> New_List
,
346 Handled_Statement_Sequence
=>
347 Make_Handled_Sequence_Of_Statements
(Loc
,
348 Statements
=> Body_Stmts
)));
350 if not Debug_Generated_Code
then
351 Set_Debug_Info_Off
(Func_Id
);
354 Set_Is_Pure
(Func_Id
);
356 end Build_Array_VS_Func
;
358 --------------------------
359 -- Build_Record_VS_Func --
360 --------------------------
364 -- function _Valid_Scalars (X : T) return Boolean is
366 -- -- Check discriminants
368 -- if not X.D1'Valid_Scalars or else
369 -- not X.D2'Valid_Scalars or else
375 -- -- Check components
377 -- if not X.C1'Valid_Scalars or else
378 -- not X.C2'Valid_Scalars or else
384 -- -- Check variant part
388 -- if not X.C2'Valid_Scalars or else
389 -- not X.C3'Valid_Scalars or else
396 -- if not X.Cn'Valid_Scalars or else
404 -- end _Valid_Scalars;
406 function Build_Record_VS_Func
408 Nod
: Node_Id
) return Entity_Id
410 Loc
: constant Source_Ptr
:= Sloc
(R_Type
);
411 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
412 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_X
);
414 function Make_VS_Case
417 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
;
418 -- Building block for variant valid scalars. Given a Component_List node
419 -- CL, it generates an 'if' followed by a 'case' statement that compares
420 -- all components of local temporaries named X and Y (that are declared
421 -- as formals at some upper level). E provides the Sloc to be used for
422 -- the generated code.
426 L
: List_Id
) return Node_Id
;
427 -- Building block for variant validate scalars. Given the list, L, of
428 -- components (or discriminants) L, it generates a return statement that
429 -- compares all components of local temporaries named X and Y (that are
430 -- declared as formals at some upper level). E provides the Sloc to be
431 -- used for the generated code.
437 -- <Make_VS_If on shared components>
440 -- when V1 => <Make_VS_Case> on subcomponents
442 -- when Vn => <Make_VS_Case> on subcomponents
445 function Make_VS_Case
448 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
450 Loc
: constant Source_Ptr
:= Sloc
(E
);
451 Result
: constant List_Id
:= New_List
;
456 Append_To
(Result
, Make_VS_If
(E
, Component_Items
(CL
)));
458 if No
(Variant_Part
(CL
)) then
462 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
468 Alt_List
:= New_List
;
469 while Present
(Variant
) loop
471 Make_Case_Statement_Alternative
(Loc
,
472 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
474 Make_VS_Case
(E
, Component_List
(Variant
), Discrs
)));
475 Next_Non_Pragma
(Variant
);
479 Make_Case_Statement
(Loc
,
481 Make_Selected_Component
(Loc
,
482 Prefix
=> Make_Identifier
(Loc
, Name_X
),
483 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
484 Alternatives
=> Alt_List
));
496 -- not X.C1'Valid_Scalars
498 -- not X.C2'Valid_Scalars
504 -- or a null statement if the list L is empty
508 L
: List_Id
) return Node_Id
510 Loc
: constant Source_Ptr
:= Sloc
(E
);
513 Field_Name
: Name_Id
;
518 return Make_Null_Statement
(Loc
);
523 C
:= First_Non_Pragma
(L
);
524 while Present
(C
) loop
525 Def_Id
:= Defining_Identifier
(C
);
526 Field_Name
:= Chars
(Def_Id
);
528 -- The tags need not be checked since they will always be valid
530 -- Note also that in the following, we use Make_Identifier for
531 -- the component names. Use of New_Occurrence_Of to identify
532 -- the components would be incorrect because wrong entities for
533 -- discriminants could be picked up in the private type case.
535 -- Don't bother with abstract parent in interface case
537 if Field_Name
= Name_uParent
538 and then Is_Interface
(Etype
(Def_Id
))
542 -- Don't bother with tag, always valid, and not scalar anyway
544 elsif Field_Name
= Name_uTag
then
547 -- Don't bother with component with no scalar components
549 elsif not Scalar_Part_Present
(Etype
(Def_Id
)) then
552 -- Normal case, generate Valid_Scalars attribute reference
555 Evolve_Or_Else
(Cond
,
558 Make_Attribute_Reference
(Loc
,
560 Make_Selected_Component
(Loc
,
562 Make_Identifier
(Loc
, Name_X
),
564 Make_Identifier
(Loc
, Field_Name
)),
565 Attribute_Name
=> Name_Valid_Scalars
)));
572 return Make_Null_Statement
(Loc
);
576 Make_Implicit_If_Statement
(E
,
578 Then_Statements
=> New_List
(
579 Make_Simple_Return_Statement
(Loc
,
581 New_Occurrence_Of
(Standard_False
, Loc
))));
588 Def
: constant Node_Id
:= Parent
(R_Type
);
589 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
590 Stmts
: constant List_Id
:= New_List
;
591 Pspecs
: constant List_Id
:= New_List
;
593 -- Start of processing for Build_Record_VS_Func
597 Make_Parameter_Specification
(Loc
,
598 Defining_Identifier
=> X
,
599 Parameter_Type
=> New_Occurrence_Of
(R_Type
, Loc
)));
602 Make_VS_If
(R_Type
, Discriminant_Specifications
(Def
)));
603 Append_List_To
(Stmts
, Make_VS_Case
(R_Type
, Comps
));
606 Make_Simple_Return_Statement
(Loc
,
607 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
610 Make_Subprogram_Body
(Loc
,
612 Make_Function_Specification
(Loc
,
613 Defining_Unit_Name
=> Func_Id
,
614 Parameter_Specifications
=> Pspecs
,
615 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
616 Declarations
=> New_List
,
617 Handled_Statement_Sequence
=>
618 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)),
619 Suppress
=> Discriminant_Check
);
621 if not Debug_Generated_Code
then
622 Set_Debug_Info_Off
(Func_Id
);
625 Set_Is_Pure
(Func_Id
);
627 end Build_Record_VS_Func
;
629 ----------------------------------
630 -- Compile_Stream_Body_In_Scope --
631 ----------------------------------
633 procedure Compile_Stream_Body_In_Scope
639 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
640 Curr
: constant Entity_Id
:= Current_Scope
;
641 Install
: Boolean := False;
642 Scop
: Entity_Id
:= Scope
(Arr
);
646 and then not In_Open_Scopes
(Scop
)
647 and then Ekind
(Scop
) = E_Package
652 -- The component type may be private, in which case we install its
653 -- full view to compile the subprogram.
655 -- The component type may be private, in which case we install its
656 -- full view to compile the subprogram. We do not do this if the
657 -- type has a Stream_Convert pragma, which indicates that there are
658 -- special stream-processing operations for that type (for example
659 -- Unbounded_String and its wide varieties).
661 Scop
:= Scope
(C_Type
);
663 if Is_Private_Type
(C_Type
)
664 and then Present
(Full_View
(C_Type
))
665 and then not In_Open_Scopes
(Scop
)
666 and then Ekind
(Scop
) = E_Package
667 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
673 -- If we are within an instance body, then all visibility has been
674 -- established already and there is no need to install the package.
676 if Install
and then not In_Instance_Body
then
678 Install_Visible_Declarations
(Scop
);
679 Install_Private_Declarations
(Scop
);
681 -- The entities in the package are now visible, but the generated
682 -- stream entity must appear in the current scope (usually an
683 -- enclosing stream function) so that itypes all have their proper
692 Insert_Action
(N
, Decl
);
694 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
699 -- Remove extra copy of current scope, and package itself
702 End_Package_Scope
(Scop
);
704 end Compile_Stream_Body_In_Scope
;
706 -----------------------------------
707 -- Expand_Access_To_Protected_Op --
708 -----------------------------------
710 procedure Expand_Access_To_Protected_Op
715 -- The value of the attribute_reference is a record containing two
716 -- fields: an access to the protected object, and an access to the
717 -- subprogram itself. The prefix is a selected component.
719 Loc
: constant Source_Ptr
:= Sloc
(N
);
721 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
724 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
725 Acc
: constant Entity_Id
:=
726 Etype
(Next_Component
(First_Component
(E_T
)));
730 -- Start of processing for Expand_Access_To_Protected_Op
733 -- Within the body of the protected type, the prefix designates a local
734 -- operation, and the object is the first parameter of the corresponding
735 -- protected body of the current enclosing operation.
737 if Is_Entity_Name
(Pref
) then
738 -- All indirect calls are external calls, so must do locking and
739 -- barrier reevaluation, even if the 'Access occurs within the
740 -- protected body. Hence the call to External_Subprogram, as opposed
741 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
742 -- that indirect calls from within the same protected body will
743 -- deadlock, as allowed by RM-9.5.1(8,15,17).
745 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
747 -- Don't traverse the scopes when the attribute occurs within an init
748 -- proc, because we directly use the _init formal of the init proc in
751 Curr
:= Current_Scope
;
752 if not Is_Init_Proc
(Curr
) then
753 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
755 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
756 Curr
:= Scope
(Curr
);
760 -- In case of protected entries the first formal of its Protected_
761 -- Body_Subprogram is the address of the object.
763 if Ekind
(Curr
) = E_Entry
then
767 (Protected_Body_Subprogram
(Curr
)), Loc
);
769 -- If the current scope is an init proc, then use the address of the
770 -- _init formal as the object reference.
772 elsif Is_Init_Proc
(Curr
) then
774 Make_Attribute_Reference
(Loc
,
775 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
776 Attribute_Name
=> Name_Address
);
778 -- In case of protected subprograms the first formal of its
779 -- Protected_Body_Subprogram is the object and we get its address.
783 Make_Attribute_Reference
(Loc
,
787 (Protected_Body_Subprogram
(Curr
)), Loc
),
788 Attribute_Name
=> Name_Address
);
791 -- Case where the prefix is not an entity name. Find the
792 -- version of the protected operation to be called from
793 -- outside the protected object.
799 (Entity
(Selector_Name
(Pref
))), Loc
);
802 Make_Attribute_Reference
(Loc
,
803 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
804 Attribute_Name
=> Name_Address
);
808 Make_Attribute_Reference
(Loc
,
810 Attribute_Name
=> Name_Access
);
812 -- We set the type of the access reference to the already generated
813 -- access_to_subprogram type, and declare the reference analyzed, to
814 -- prevent further expansion when the enclosing aggregate is analyzed.
816 Set_Etype
(Sub_Ref
, Acc
);
817 Set_Analyzed
(Sub_Ref
);
821 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
823 -- Sub_Ref has been marked as analyzed, but we still need to make sure
824 -- Sub is correctly frozen.
826 Freeze_Before
(N
, Entity
(Sub
));
829 Analyze_And_Resolve
(N
, E_T
);
831 -- For subsequent analysis, the node must retain its type. The backend
832 -- will replace it with the equivalent type where needed.
835 end Expand_Access_To_Protected_Op
;
837 --------------------------
838 -- Expand_Fpt_Attribute --
839 --------------------------
841 procedure Expand_Fpt_Attribute
847 Loc
: constant Source_Ptr
:= Sloc
(N
);
848 Typ
: constant Entity_Id
:= Etype
(N
);
852 -- The function name is the selected component Attr_xxx.yyy where
853 -- Attr_xxx is the package name, and yyy is the argument Nam.
855 -- Note: it would be more usual to have separate RE entries for each
856 -- of the entities in the Fat packages, but first they have identical
857 -- names (so we would have to have lots of renaming declarations to
858 -- meet the normal RE rule of separate names for all runtime entities),
859 -- and second there would be an awful lot of them.
862 Make_Selected_Component
(Loc
,
863 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
864 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
866 -- The generated call is given the provided set of parameters, and then
867 -- wrapped in a conversion which converts the result to the target type
868 -- We use the base type as the target because a range check may be
872 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
873 Make_Function_Call
(Loc
,
875 Parameter_Associations
=> Args
)));
877 Analyze_And_Resolve
(N
, Typ
);
878 end Expand_Fpt_Attribute
;
880 ----------------------------
881 -- Expand_Fpt_Attribute_R --
882 ----------------------------
884 -- The single argument is converted to its root type to call the
885 -- appropriate runtime function, with the actual call being built
886 -- by Expand_Fpt_Attribute
888 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
889 E1
: constant Node_Id
:= First
(Expressions
(N
));
893 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
895 (N
, Pkg
, Attribute_Name
(N
),
896 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
897 end Expand_Fpt_Attribute_R
;
899 -----------------------------
900 -- Expand_Fpt_Attribute_RI --
901 -----------------------------
903 -- The first argument is converted to its root type and the second
904 -- argument is converted to standard long long integer to call the
905 -- appropriate runtime function, with the actual call being built
906 -- by Expand_Fpt_Attribute
908 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
909 E1
: constant Node_Id
:= First
(Expressions
(N
));
912 E2
: constant Node_Id
:= Next
(E1
);
914 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
916 (N
, Pkg
, Attribute_Name
(N
),
918 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
919 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
920 end Expand_Fpt_Attribute_RI
;
922 -----------------------------
923 -- Expand_Fpt_Attribute_RR --
924 -----------------------------
926 -- The two arguments are converted to their root types to call the
927 -- appropriate runtime function, with the actual call being built
928 -- by Expand_Fpt_Attribute
930 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
931 E1
: constant Node_Id
:= First
(Expressions
(N
));
932 E2
: constant Node_Id
:= Next
(E1
);
937 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
939 (N
, Pkg
, Attribute_Name
(N
),
941 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
942 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
943 end Expand_Fpt_Attribute_RR
;
945 ---------------------------------
946 -- Expand_Loop_Entry_Attribute --
947 ---------------------------------
949 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
950 procedure Build_Conditional_Block
954 If_Stmt
: out Node_Id
;
955 Blk_Stmt
: out Node_Id
);
956 -- Create a block Blk_Stmt with an empty declarative list and a single
957 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
958 -- condition Cond. If_Stmt is Empty when there is no condition provided.
960 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
961 -- Determine whether loop statement N denotes an Ada 2012 iteration over
964 -----------------------------
965 -- Build_Conditional_Block --
966 -----------------------------
968 procedure Build_Conditional_Block
972 If_Stmt
: out Node_Id
;
973 Blk_Stmt
: out Node_Id
)
976 -- Do not reanalyze the original loop statement because it is simply
979 Set_Analyzed
(Loop_Stmt
);
982 Make_Block_Statement
(Loc
,
983 Declarations
=> New_List
,
984 Handled_Statement_Sequence
=>
985 Make_Handled_Sequence_Of_Statements
(Loc
,
986 Statements
=> New_List
(Loop_Stmt
)));
988 if Present
(Cond
) then
990 Make_If_Statement
(Loc
,
992 Then_Statements
=> New_List
(Blk_Stmt
));
996 end Build_Conditional_Block
;
998 ------------------------
999 -- Is_Array_Iteration --
1000 ------------------------
1002 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1003 Stmt
: constant Node_Id
:= Original_Node
(N
);
1007 if Nkind
(Stmt
) = N_Loop_Statement
1008 and then Present
(Iteration_Scheme
(Stmt
))
1009 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1011 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1014 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1018 end Is_Array_Iteration
;
1022 Pref
: constant Node_Id
:= Prefix
(N
);
1023 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1024 Exprs
: constant List_Id
:= Expressions
(N
);
1028 Installed
: Boolean;
1030 Loop_Id
: Entity_Id
;
1031 Loop_Stmt
: Node_Id
;
1034 Temp_Decl
: Node_Id
;
1035 Temp_Id
: Entity_Id
;
1037 -- Start of processing for Expand_Loop_Entry_Attribute
1040 -- Step 1: Find the related loop
1042 -- The loop label variant of attribute 'Loop_Entry already has all the
1043 -- information in its expression.
1045 if Present
(Exprs
) then
1046 Loop_Id
:= Entity
(First
(Exprs
));
1047 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1049 -- Climb the parent chain to find the nearest enclosing loop. Skip
1050 -- all internally generated loops for quantified expressions and for
1051 -- element iterators over multidimensional arrays because the pragma
1052 -- applies to source loop.
1056 while Present
(Loop_Stmt
) loop
1057 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1058 and then Comes_From_Source
(Loop_Stmt
)
1063 Loop_Stmt
:= Parent
(Loop_Stmt
);
1066 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1069 Loc
:= Sloc
(Loop_Stmt
);
1071 -- Step 2: Transform the loop
1073 -- The loop has already been transformed during the expansion of a prior
1074 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1076 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1078 -- When the related loop name appears as the argument of attribute
1079 -- Loop_Entry, the corresponding label construct is the generated
1080 -- block statement. This is because the expander reuses the label.
1082 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1083 Decls
:= Declarations
(Loop_Stmt
);
1085 -- In all other cases, the loop must appear in the handled sequence
1086 -- of statements of the generated block.
1090 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1092 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1094 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1099 -- Transform the loop into a conditional block
1102 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1103 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1105 -- Infinite loops are transformed into:
1108 -- Temp1 : constant <type of Pref1> := <Pref1>;
1110 -- TempN : constant <type of PrefN> := <PrefN>;
1113 -- <original source statements with attribute rewrites>
1118 Build_Conditional_Block
(Loc
,
1120 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1126 -- While loops are transformed into:
1128 -- function Fnn return Boolean is
1130 -- <condition actions>
1131 -- return <condition>;
1136 -- Temp1 : constant <type of Pref1> := <Pref1>;
1138 -- TempN : constant <type of PrefN> := <PrefN>;
1141 -- <original source statements with attribute rewrites>
1142 -- exit when not Fnn;
1147 -- Note that loops over iterators and containers are already
1148 -- converted into while loops.
1150 elsif Present
(Condition
(Scheme
)) then
1152 Func_Decl
: Node_Id
;
1153 Func_Id
: Entity_Id
;
1157 -- Wrap the condition of the while loop in a Boolean function.
1158 -- This avoids the duplication of the same code which may lead
1159 -- to gigi issues with respect to multiple declaration of the
1160 -- same entity in the presence of side effects or checks. Note
1161 -- that the condition actions must also be relocated to the
1162 -- wrapping function.
1165 -- <condition actions>
1166 -- return <condition>;
1168 if Present
(Condition_Actions
(Scheme
)) then
1169 Stmts
:= Condition_Actions
(Scheme
);
1175 Make_Simple_Return_Statement
(Loc
,
1176 Expression
=> Relocate_Node
(Condition
(Scheme
))));
1179 -- function Fnn return Boolean is
1184 Func_Id
:= Make_Temporary
(Loc
, 'F');
1186 Make_Subprogram_Body
(Loc
,
1188 Make_Function_Specification
(Loc
,
1189 Defining_Unit_Name
=> Func_Id
,
1190 Result_Definition
=>
1191 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1192 Declarations
=> Empty_List
,
1193 Handled_Statement_Sequence
=>
1194 Make_Handled_Sequence_Of_Statements
(Loc
,
1195 Statements
=> Stmts
));
1197 -- The function is inserted before the related loop. Make sure
1198 -- to analyze it in the context of the loop's enclosing scope.
1200 Push_Scope
(Scope
(Loop_Id
));
1201 Insert_Action
(Loop_Stmt
, Func_Decl
);
1204 -- Transform the original while loop into an infinite loop
1205 -- where the last statement checks the negated condition. This
1206 -- placement ensures that the condition will not be evaluated
1207 -- twice on the first iteration.
1209 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1213 -- exit when not Fnn;
1215 Append_To
(Statements
(Loop_Stmt
),
1216 Make_Exit_Statement
(Loc
,
1220 Make_Function_Call
(Loc
,
1221 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1223 Build_Conditional_Block
(Loc
,
1225 Make_Function_Call
(Loc
,
1226 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1227 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1232 -- Ada 2012 iteration over an array is transformed into:
1234 -- if <Array_Nam>'Length (1) > 0
1235 -- and then <Array_Nam>'Length (N) > 0
1238 -- Temp1 : constant <type of Pref1> := <Pref1>;
1240 -- TempN : constant <type of PrefN> := <PrefN>;
1242 -- for X in ... loop -- multiple loops depending on dims
1243 -- <original source statements with attribute rewrites>
1248 elsif Is_Array_Iteration
(Loop_Stmt
) then
1250 Array_Nam
: constant Entity_Id
:=
1251 Entity
(Name
(Iterator_Specification
1252 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1253 Num_Dims
: constant Pos
:=
1254 Number_Dimensions
(Etype
(Array_Nam
));
1255 Cond
: Node_Id
:= Empty
;
1259 -- Generate a check which determines whether all dimensions of
1260 -- the array are non-null.
1262 for Dim
in 1 .. Num_Dims
loop
1266 Make_Attribute_Reference
(Loc
,
1267 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1268 Attribute_Name
=> Name_Length
,
1269 Expressions
=> New_List
(
1270 Make_Integer_Literal
(Loc
, Dim
))),
1272 Make_Integer_Literal
(Loc
, 0));
1280 Right_Opnd
=> Check
);
1284 Build_Conditional_Block
(Loc
,
1286 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1291 -- For loops are transformed into:
1293 -- if <Low> <= <High> then
1295 -- Temp1 : constant <type of Pref1> := <Pref1>;
1297 -- TempN : constant <type of PrefN> := <PrefN>;
1299 -- for <Def_Id> in <Low> .. <High> loop
1300 -- <original source statements with attribute rewrites>
1305 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1307 Loop_Spec
: constant Node_Id
:=
1308 Loop_Parameter_Specification
(Scheme
);
1313 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1315 -- When the loop iterates over a subtype indication with a
1316 -- range, use the low and high bounds of the subtype itself.
1318 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1319 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1322 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1329 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1330 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1332 Build_Conditional_Block
(Loc
,
1334 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1340 Decls
:= Declarations
(Blk
);
1343 -- Step 3: Create a constant to capture the value of the prefix at the
1344 -- entry point into the loop.
1346 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1348 -- Preserve the tag of the prefix by offering a specific view of the
1349 -- class-wide version of the prefix.
1351 if Is_Tagged_Type
(Base_Typ
) then
1352 Tagged_Case
: declare
1353 CW_Temp
: Entity_Id
;
1358 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1360 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1361 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1364 Make_Object_Declaration
(Loc
,
1365 Defining_Identifier
=> CW_Temp
,
1366 Constant_Present
=> True,
1367 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1369 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1370 Append_To
(Decls
, Aux_Decl
);
1373 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1376 Make_Object_Renaming_Declaration
(Loc
,
1377 Defining_Identifier
=> Temp_Id
,
1378 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1380 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1381 Append_To
(Decls
, Temp_Decl
);
1387 Untagged_Case
: declare
1388 Temp_Expr
: Node_Id
;
1393 -- Generate a nominal type for the constant when the prefix is of
1394 -- a constrained type. This is achieved by setting the Etype of
1395 -- the relocated prefix to its base type. Since the prefix is now
1396 -- the initialization expression of the constant, its freezing
1397 -- will produce a proper nominal type.
1399 Temp_Expr
:= Relocate_Node
(Pref
);
1400 Set_Etype
(Temp_Expr
, Base_Typ
);
1403 -- Temp : constant Base_Typ := Pref;
1406 Make_Object_Declaration
(Loc
,
1407 Defining_Identifier
=> Temp_Id
,
1408 Constant_Present
=> True,
1409 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1410 Expression
=> Temp_Expr
);
1411 Append_To
(Decls
, Temp_Decl
);
1415 -- Step 4: Analyze all bits
1417 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1419 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1420 -- associated loop, ensure the proper visibility for analysis.
1422 if not Installed
then
1423 Push_Scope
(Scope
(Loop_Id
));
1426 -- The analysis of the conditional block takes care of the constant
1429 if Present
(Result
) then
1430 Rewrite
(Loop_Stmt
, Result
);
1431 Analyze
(Loop_Stmt
);
1433 -- The conditional block was analyzed when a previous 'Loop_Entry was
1434 -- expanded. There is no point in reanalyzing the block, simply analyze
1435 -- the declaration of the constant.
1438 if Present
(Aux_Decl
) then
1442 Analyze
(Temp_Decl
);
1445 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1448 if not Installed
then
1451 end Expand_Loop_Entry_Attribute
;
1453 ------------------------------
1454 -- Expand_Min_Max_Attribute --
1455 ------------------------------
1457 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1459 -- Min and Max are handled by the back end (except that static cases
1460 -- have already been evaluated during semantic processing, although the
1461 -- back end should not count on this). The one bit of special processing
1462 -- required in the normal case is that these two attributes typically
1463 -- generate conditionals in the code, so check the relevant restriction.
1465 Check_Restriction
(No_Implicit_Conditionals
, N
);
1467 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1469 if Modify_Tree_For_C
then
1471 Loc
: constant Source_Ptr
:= Sloc
(N
);
1472 Typ
: constant Entity_Id
:= Etype
(N
);
1473 Expr
: constant Node_Id
:= First
(Expressions
(N
));
1474 Left
: constant Node_Id
:= Relocate_Node
(Expr
);
1475 Right
: constant Node_Id
:= Relocate_Node
(Next
(Expr
));
1477 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
;
1478 -- Returns Left >= Right for Max, Left <= Right for Min
1484 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
is
1486 if Attribute_Name
(N
) = Name_Max
then
1490 Right_Opnd
=> Right
);
1495 Right_Opnd
=> Right
);
1499 -- Start of processing for Min_Max
1502 -- If both Left and Right are side effect free, then we can just
1503 -- use Duplicate_Expr to duplicate the references and return
1505 -- (if Left >=|<= Right then Left else Right)
1507 if Side_Effect_Free
(Left
) and then Side_Effect_Free
(Right
) then
1509 Make_If_Expression
(Loc
,
1510 Expressions
=> New_List
(
1511 Make_Compare
(Left
, Right
),
1512 Duplicate_Subexpr_No_Checks
(Left
),
1513 Duplicate_Subexpr_No_Checks
(Right
))));
1515 -- Otherwise we generate declarations to capture the values.
1517 -- The translation is
1520 -- T1 : constant typ := Left;
1521 -- T2 : constant typ := Right;
1523 -- (if T1 >=|<= T2 then T1 else T2)
1528 T1
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1529 T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Right
);
1533 Make_Expression_With_Actions
(Loc
,
1534 Actions
=> New_List
(
1535 Make_Object_Declaration
(Loc
,
1536 Defining_Identifier
=> T1
,
1537 Constant_Present
=> True,
1538 Object_Definition
=>
1539 New_Occurrence_Of
(Etype
(Left
), Loc
),
1540 Expression
=> Relocate_Node
(Left
)),
1542 Make_Object_Declaration
(Loc
,
1543 Defining_Identifier
=> T2
,
1544 Constant_Present
=> True,
1545 Object_Definition
=>
1546 New_Occurrence_Of
(Etype
(Right
), Loc
),
1547 Expression
=> Relocate_Node
(Right
))),
1550 Make_If_Expression
(Loc
,
1551 Expressions
=> New_List
(
1553 (New_Occurrence_Of
(T1
, Loc
),
1554 New_Occurrence_Of
(T2
, Loc
)),
1555 New_Occurrence_Of
(T1
, Loc
),
1556 New_Occurrence_Of
(T2
, Loc
)))));
1560 Analyze_And_Resolve
(N
, Typ
);
1563 end Expand_Min_Max_Attribute
;
1565 ----------------------------------
1566 -- Expand_N_Attribute_Reference --
1567 ----------------------------------
1569 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1570 Loc
: constant Source_Ptr
:= Sloc
(N
);
1571 Typ
: constant Entity_Id
:= Etype
(N
);
1572 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1573 Pref
: constant Node_Id
:= Prefix
(N
);
1574 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1575 Exprs
: constant List_Id
:= Expressions
(N
);
1576 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1578 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1579 -- Rewrites a stream attribute for Read, Write or Output with the
1580 -- procedure call. Pname is the entity for the procedure to call.
1582 ------------------------------
1583 -- Rewrite_Stream_Proc_Call --
1584 ------------------------------
1586 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1587 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1588 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1589 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1590 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1591 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1594 -- The expansion depends on Item, the second actual, which is
1595 -- the object being streamed in or out.
1597 -- If the item is a component of a packed array type, and
1598 -- a conversion is needed on exit, we introduce a temporary to
1599 -- hold the value, because otherwise the packed reference will
1600 -- not be properly expanded.
1602 if Nkind
(Item
) = N_Indexed_Component
1603 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1604 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1608 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1614 Make_Object_Declaration
(Loc
,
1615 Defining_Identifier
=> Temp
,
1616 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1617 Set_Etype
(Temp
, Formal_Typ
);
1620 Make_Assignment_Statement
(Loc
,
1621 Name
=> New_Copy_Tree
(Item
),
1623 Unchecked_Convert_To
1624 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1626 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1630 Make_Procedure_Call_Statement
(Loc
,
1631 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1632 Parameter_Associations
=> Exprs
),
1635 Rewrite
(N
, Make_Null_Statement
(Loc
));
1640 -- For the class-wide dispatching cases, and for cases in which
1641 -- the base type of the second argument matches the base type of
1642 -- the corresponding formal parameter (that is to say the stream
1643 -- operation is not inherited), we are all set, and can use the
1644 -- argument unchanged.
1646 if not Is_Class_Wide_Type
(Entity
(Pref
))
1647 and then not Is_Class_Wide_Type
(Etype
(Item
))
1648 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1650 -- Perform a view conversion when either the argument or the
1651 -- formal parameter are of a private type.
1653 if Is_Private_Type
(Formal_Typ
)
1654 or else Is_Private_Type
(Item_Typ
)
1657 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1659 -- Otherwise perform a regular type conversion to ensure that all
1660 -- relevant checks are installed.
1663 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1666 -- For untagged derived types set Assignment_OK, to prevent
1667 -- copies from being created when the unchecked conversion
1668 -- is expanded (which would happen in Remove_Side_Effects
1669 -- if Expand_N_Unchecked_Conversion were allowed to call
1670 -- Force_Evaluation). The copy could violate Ada semantics in
1671 -- cases such as an actual that is an out parameter. Note that
1672 -- this approach is also used in exp_ch7 for calls to controlled
1673 -- type operations to prevent problems with actuals wrapped in
1674 -- unchecked conversions.
1676 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1677 Set_Assignment_OK
(Item
);
1681 -- The stream operation to call may be a renaming created by an
1682 -- attribute definition clause, and may not be frozen yet. Ensure
1683 -- that it has the necessary extra formals.
1685 if not Is_Frozen
(Pname
) then
1686 Create_Extra_Formals
(Pname
);
1689 -- And now rewrite the call
1692 Make_Procedure_Call_Statement
(Loc
,
1693 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1694 Parameter_Associations
=> Exprs
));
1697 end Rewrite_Stream_Proc_Call
;
1699 -- Start of processing for Expand_N_Attribute_Reference
1702 -- Do required validity checking, if enabled. Do not apply check to
1703 -- output parameters of an Asm instruction, since the value of this
1704 -- is not set till after the attribute has been elaborated, and do
1705 -- not apply the check to the arguments of a 'Read or 'Input attribute
1706 -- reference since the scalar argument is an OUT scalar.
1708 if Validity_Checks_On
and then Validity_Check_Operands
1709 and then Id
/= Attribute_Asm_Output
1710 and then Id
/= Attribute_Read
1711 and then Id
/= Attribute_Input
1716 Expr
:= First
(Expressions
(N
));
1717 while Present
(Expr
) loop
1718 Ensure_Valid
(Expr
);
1724 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1725 -- place function, then a temporary return object needs to be created
1726 -- and access to it must be passed to the function. Currently we limit
1727 -- such functions to those with inherently limited result subtypes, but
1728 -- eventually we plan to expand the functions that are treated as
1729 -- build-in-place to include other composite result types.
1731 if Ada_Version
>= Ada_2005
1732 and then Is_Build_In_Place_Function_Call
(Pref
)
1734 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1737 -- If prefix is a protected type name, this is a reference to the
1738 -- current instance of the type. For a component definition, nothing
1739 -- to do (expansion will occur in the init proc). In other contexts,
1740 -- rewrite into reference to current instance.
1742 if Is_Protected_Self_Reference
(Pref
)
1744 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1745 N_Discriminant_Association
)
1746 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1747 N_Component_Definition
)
1749 -- No action needed for these attributes since the current instance
1750 -- will be rewritten to be the name of the _object parameter
1751 -- associated with the enclosing protected subprogram (see below).
1753 and then Id
/= Attribute_Access
1754 and then Id
/= Attribute_Unchecked_Access
1755 and then Id
/= Attribute_Unrestricted_Access
1757 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1761 -- Remaining processing depends on specific attribute
1763 -- Note: individual sections of the following case statement are
1764 -- allowed to assume there is no code after the case statement, and
1765 -- are legitimately allowed to execute return statements if they have
1766 -- nothing more to do.
1770 -- Attributes related to Ada 2012 iterators
1772 when Attribute_Constant_Indexing
1773 | Attribute_Default_Iterator
1774 | Attribute_Implicit_Dereference
1775 | Attribute_Iterable
1776 | Attribute_Iterator_Element
1777 | Attribute_Variable_Indexing
1781 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1782 -- were already rejected by the parser. Thus they shouldn't appear here.
1784 when Internal_Attribute_Id
=>
1785 raise Program_Error
;
1791 when Attribute_Access
1792 | Attribute_Unchecked_Access
1793 | Attribute_Unrestricted_Access
1795 Access_Cases
: declare
1796 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1797 Btyp_DDT
: Entity_Id
;
1799 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1800 -- If N denotes a compound name (selected component, indexed
1801 -- component, or slice), returns the name of the outermost such
1802 -- enclosing object. Otherwise returns N. If the object is a
1803 -- renaming, then the renamed object is returned.
1805 ----------------------
1806 -- Enclosing_Object --
1807 ----------------------
1809 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1814 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1815 N_Indexed_Component
,
1818 Obj_Name
:= Prefix
(Obj_Name
);
1821 return Get_Referenced_Object
(Obj_Name
);
1822 end Enclosing_Object
;
1824 -- Local declarations
1826 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1828 -- Start of processing for Access_Cases
1831 Btyp_DDT
:= Designated_Type
(Btyp
);
1833 -- Handle designated types that come from the limited view
1835 if From_Limited_With
(Btyp_DDT
)
1836 and then Has_Non_Limited_View
(Btyp_DDT
)
1838 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
1841 -- In order to improve the text of error messages, the designated
1842 -- type of access-to-subprogram itypes is set by the semantics as
1843 -- the associated subprogram entity (see sem_attr). Now we replace
1844 -- such node with the proper E_Subprogram_Type itype.
1846 if Id
= Attribute_Unrestricted_Access
1847 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
1849 -- The following conditions ensure that this special management
1850 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1851 -- At this stage other cases in which the designated type is
1852 -- still a subprogram (instead of an E_Subprogram_Type) are
1853 -- wrong because the semantics must have overridden the type of
1854 -- the node with the type imposed by the context.
1856 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
1857 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
1859 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
1863 Subp
: constant Entity_Id
:=
1864 Directly_Designated_Type
(Typ
);
1866 Extra
: Entity_Id
:= Empty
;
1867 New_Formal
: Entity_Id
;
1868 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1869 Subp_Typ
: Entity_Id
;
1872 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
1873 Set_Etype
(Subp_Typ
, Etype
(Subp
));
1874 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1876 if Present
(Old_Formal
) then
1877 New_Formal
:= New_Copy
(Old_Formal
);
1878 Set_First_Entity
(Subp_Typ
, New_Formal
);
1881 Set_Scope
(New_Formal
, Subp_Typ
);
1882 Etyp
:= Etype
(New_Formal
);
1884 -- Handle itypes. There is no need to duplicate
1885 -- here the itypes associated with record types
1886 -- (i.e the implicit full view of private types).
1889 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
1891 Extra
:= New_Copy
(Etyp
);
1892 Set_Parent
(Extra
, New_Formal
);
1893 Set_Etype
(New_Formal
, Extra
);
1894 Set_Scope
(Extra
, Subp_Typ
);
1897 Extra
:= New_Formal
;
1898 Next_Formal
(Old_Formal
);
1899 exit when No
(Old_Formal
);
1901 Set_Next_Entity
(New_Formal
,
1902 New_Copy
(Old_Formal
));
1903 Next_Entity
(New_Formal
);
1906 Set_Next_Entity
(New_Formal
, Empty
);
1907 Set_Last_Entity
(Subp_Typ
, Extra
);
1910 -- Now that the explicit formals have been duplicated,
1911 -- any extra formals needed by the subprogram must be
1914 if Present
(Extra
) then
1915 Set_Extra_Formal
(Extra
, Empty
);
1918 Create_Extra_Formals
(Subp_Typ
);
1919 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
1924 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
1925 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
1927 -- If prefix is a type name, this is a reference to the current
1928 -- instance of the type, within its initialization procedure.
1930 elsif Is_Entity_Name
(Pref
)
1931 and then Is_Type
(Entity
(Pref
))
1938 -- If the current instance name denotes a task type, then
1939 -- the access attribute is rewritten to be the name of the
1940 -- "_task" parameter associated with the task type's task
1941 -- procedure. An unchecked conversion is applied to ensure
1942 -- a type match in cases of expander-generated calls (e.g.
1945 if Is_Task_Type
(Entity
(Pref
)) then
1947 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
1948 while Present
(Formal
) loop
1949 exit when Chars
(Formal
) = Name_uTask
;
1950 Next_Entity
(Formal
);
1953 pragma Assert
(Present
(Formal
));
1956 Unchecked_Convert_To
(Typ
,
1957 New_Occurrence_Of
(Formal
, Loc
)));
1960 elsif Is_Protected_Type
(Entity
(Pref
)) then
1962 -- No action needed for current instance located in a
1963 -- component definition (expansion will occur in the
1966 if Is_Protected_Type
(Current_Scope
) then
1969 -- If the current instance reference is located in a
1970 -- protected subprogram or entry then rewrite the access
1971 -- attribute to be the name of the "_object" parameter.
1972 -- An unchecked conversion is applied to ensure a type
1973 -- match in cases of expander-generated calls (e.g. init
1976 -- The code may be nested in a block, so find enclosing
1977 -- scope that is a protected operation.
1984 Subp
:= Current_Scope
;
1985 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
1986 Subp
:= Scope
(Subp
);
1991 (Protected_Body_Subprogram
(Subp
));
1993 -- For a protected subprogram the _Object parameter
1994 -- is the protected record, so we create an access
1995 -- to it. The _Object parameter of an entry is an
1998 if Ekind
(Subp
) = E_Entry
then
2000 Unchecked_Convert_To
(Typ
,
2001 New_Occurrence_Of
(Formal
, Loc
)));
2006 Unchecked_Convert_To
(Typ
,
2007 Make_Attribute_Reference
(Loc
,
2008 Attribute_Name
=> Name_Unrestricted_Access
,
2010 New_Occurrence_Of
(Formal
, Loc
))));
2011 Analyze_And_Resolve
(N
);
2016 -- The expression must appear in a default expression,
2017 -- (which in the initialization procedure is the right-hand
2018 -- side of an assignment), and not in a discriminant
2023 while Present
(Par
) loop
2024 exit when Nkind
(Par
) = N_Assignment_Statement
;
2026 if Nkind
(Par
) = N_Component_Declaration
then
2030 Par
:= Parent
(Par
);
2033 if Present
(Par
) then
2035 Make_Attribute_Reference
(Loc
,
2036 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2037 Attribute_Name
=> Attribute_Name
(N
)));
2039 Analyze_And_Resolve
(N
, Typ
);
2044 -- If the prefix of an Access attribute is a dereference of an
2045 -- access parameter (or a renaming of such a dereference, or a
2046 -- subcomponent of such a dereference) and the context is a
2047 -- general access type (including the type of an object or
2048 -- component with an access_definition, but not the anonymous
2049 -- type of an access parameter or access discriminant), then
2050 -- apply an accessibility check to the access parameter. We used
2051 -- to rewrite the access parameter as a type conversion, but that
2052 -- could only be done if the immediate prefix of the Access
2053 -- attribute was the dereference, and didn't handle cases where
2054 -- the attribute is applied to a subcomponent of the dereference,
2055 -- since there's generally no available, appropriate access type
2056 -- to convert to in that case. The attribute is passed as the
2057 -- point to insert the check, because the access parameter may
2058 -- come from a renaming, possibly in a different scope, and the
2059 -- check must be associated with the attribute itself.
2061 elsif Id
= Attribute_Access
2062 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2063 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2064 and then (Ekind
(Btyp
) = E_General_Access_Type
2065 or else Is_Local_Anonymous_Access
(Btyp
))
2066 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
2067 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2068 = E_Anonymous_Access_Type
2069 and then Present
(Extra_Accessibility
2070 (Entity
(Prefix
(Enc_Object
))))
2072 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2074 -- Ada 2005 (AI-251): If the designated type is an interface we
2075 -- add an implicit conversion to force the displacement of the
2076 -- pointer to reference the secondary dispatch table.
2078 elsif Is_Interface
(Btyp_DDT
)
2079 and then (Comes_From_Source
(N
)
2080 or else Comes_From_Source
(Ref_Object
)
2081 or else (Nkind
(Ref_Object
) in N_Has_Chars
2082 and then Chars
(Ref_Object
) = Name_uInit
))
2084 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2086 -- No implicit conversion required if types match, or if
2087 -- the prefix is the class_wide_type of the interface. In
2088 -- either case passing an object of the interface type has
2089 -- already set the pointer correctly.
2091 if Btyp_DDT
= Etype
(Ref_Object
)
2092 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2094 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2099 Rewrite
(Prefix
(N
),
2100 Convert_To
(Btyp_DDT
,
2101 New_Copy_Tree
(Prefix
(N
))));
2103 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2106 -- When the object is an explicit dereference, convert the
2107 -- dereference's prefix.
2111 Obj_DDT
: constant Entity_Id
:=
2113 (Directly_Designated_Type
2114 (Etype
(Prefix
(Ref_Object
))));
2116 -- No implicit conversion required if designated types
2117 -- match, or if we have an unrestricted access.
2119 if Obj_DDT
/= Btyp_DDT
2120 and then Id
/= Attribute_Unrestricted_Access
2121 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2122 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2126 New_Copy_Tree
(Prefix
(Ref_Object
))));
2127 Analyze_And_Resolve
(N
, Typ
);
2138 -- Transforms 'Adjacent into a call to the floating-point attribute
2139 -- function Adjacent in Fat_xxx (where xxx is the root type)
2141 when Attribute_Adjacent
=>
2142 Expand_Fpt_Attribute_RR
(N
);
2148 when Attribute_Address
=> Address
: declare
2149 Task_Proc
: Entity_Id
;
2152 -- If the prefix is a task or a task type, the useful address is that
2153 -- of the procedure for the task body, i.e. the actual program unit.
2154 -- We replace the original entity with that of the procedure.
2156 if Is_Entity_Name
(Pref
)
2157 and then Is_Task_Type
(Entity
(Pref
))
2159 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2161 while Present
(Task_Proc
) loop
2162 exit when Ekind
(Task_Proc
) = E_Procedure
2163 and then Etype
(First_Formal
(Task_Proc
)) =
2164 Corresponding_Record_Type
(Ptyp
);
2165 Next_Entity
(Task_Proc
);
2168 if Present
(Task_Proc
) then
2169 Set_Entity
(Pref
, Task_Proc
);
2170 Set_Etype
(Pref
, Etype
(Task_Proc
));
2173 -- Similarly, the address of a protected operation is the address
2174 -- of the corresponding protected body, regardless of the protected
2175 -- object from which it is selected.
2177 elsif Nkind
(Pref
) = N_Selected_Component
2178 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2179 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2183 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2185 elsif Nkind
(Pref
) = N_Explicit_Dereference
2186 and then Ekind
(Ptyp
) = E_Subprogram_Type
2187 and then Convention
(Ptyp
) = Convention_Protected
2189 -- The prefix is be a dereference of an access_to_protected_
2190 -- subprogram. The desired address is the second component of
2191 -- the record that represents the access.
2194 Addr
: constant Entity_Id
:= Etype
(N
);
2195 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2196 T
: constant Entity_Id
:=
2197 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2201 Unchecked_Convert_To
(Addr
,
2202 Make_Selected_Component
(Loc
,
2203 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2204 Selector_Name
=> New_Occurrence_Of
(
2205 Next_Entity
(First_Entity
(T
)), Loc
))));
2207 Analyze_And_Resolve
(N
, Addr
);
2210 -- Ada 2005 (AI-251): Class-wide interface objects are always
2211 -- "displaced" to reference the tag associated with the interface
2212 -- type. In order to obtain the real address of such objects we
2213 -- generate a call to a run-time subprogram that returns the base
2214 -- address of the object.
2216 -- This processing is not needed in the VM case, where dispatching
2217 -- issues are taken care of by the virtual machine.
2219 elsif Is_Class_Wide_Type
(Ptyp
)
2220 and then Is_Interface
(Ptyp
)
2221 and then Tagged_Type_Expansion
2222 and then not (Nkind
(Pref
) in N_Has_Entity
2223 and then Is_Subprogram
(Entity
(Pref
)))
2226 Make_Function_Call
(Loc
,
2227 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2228 Parameter_Associations
=> New_List
(
2229 Relocate_Node
(N
))));
2234 -- Deal with packed array reference, other cases are handled by
2237 if Involves_Packed_Array_Reference
(Pref
) then
2238 Expand_Packed_Address_Reference
(N
);
2246 when Attribute_Alignment
=> Alignment
: declare
2250 -- For class-wide types, X'Class'Alignment is transformed into a
2251 -- direct reference to the Alignment of the class type, so that the
2252 -- back end does not have to deal with the X'Class'Alignment
2255 if Is_Entity_Name
(Pref
)
2256 and then Is_Class_Wide_Type
(Entity
(Pref
))
2258 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2261 -- For x'Alignment applied to an object of a class wide type,
2262 -- transform X'Alignment into a call to the predefined primitive
2263 -- operation _Alignment applied to X.
2265 elsif Is_Class_Wide_Type
(Ptyp
) then
2267 Make_Attribute_Reference
(Loc
,
2269 Attribute_Name
=> Name_Tag
);
2271 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2273 -- Case where the context is a specific integer type with which
2274 -- the original attribute was compatible. The function has a
2275 -- specific type as well, so to preserve the compatibility we
2276 -- must convert explicitly.
2278 if Typ
/= Standard_Integer
then
2279 New_Node
:= Convert_To
(Typ
, New_Node
);
2282 Rewrite
(N
, New_Node
);
2283 Analyze_And_Resolve
(N
, Typ
);
2286 -- For all other cases, we just have to deal with the case of
2287 -- the fact that the result can be universal.
2290 Apply_Universal_Integer_Attribute_Checks
(N
);
2298 -- We compute this if a packed array reference was present, otherwise we
2299 -- leave the computation up to the back end.
2301 when Attribute_Bit
=>
2302 if Involves_Packed_Array_Reference
(Pref
) then
2303 Expand_Packed_Bit_Reference
(N
);
2305 Apply_Universal_Integer_Attribute_Checks
(N
);
2312 -- We compute this if a component clause was present, otherwise we leave
2313 -- the computation up to the back end, since we don't know what layout
2316 -- Note that the attribute can apply to a naked record component
2317 -- in generated code (i.e. the prefix is an identifier that
2318 -- references the component or discriminant entity).
2320 when Attribute_Bit_Position
=> Bit_Position
: declare
2324 if Nkind
(Pref
) = N_Identifier
then
2325 CE
:= Entity
(Pref
);
2327 CE
:= Entity
(Selector_Name
(Pref
));
2330 if Known_Static_Component_Bit_Offset
(CE
) then
2332 Make_Integer_Literal
(Loc
,
2333 Intval
=> Component_Bit_Offset
(CE
)));
2334 Analyze_And_Resolve
(N
, Typ
);
2337 Apply_Universal_Integer_Attribute_Checks
(N
);
2345 -- A reference to P'Body_Version or P'Version is expanded to
2348 -- pragma Import (C, Vnn, "uuuuT");
2350 -- Get_Version_String (Vnn)
2352 -- where uuuu is the unit name (dots replaced by double underscore)
2353 -- and T is B for the cases of Body_Version, or Version applied to a
2354 -- subprogram acting as its own spec, and S for Version applied to a
2355 -- subprogram spec or package. This sequence of code references the
2356 -- unsigned constant created in the main program by the binder.
2358 -- A special exception occurs for Standard, where the string returned
2359 -- is a copy of the library string in gnatvsn.ads.
2361 when Attribute_Body_Version
2365 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2370 -- If not library unit, get to containing library unit
2372 Pent
:= Entity
(Pref
);
2373 while Pent
/= Standard_Standard
2374 and then Scope
(Pent
) /= Standard_Standard
2375 and then not Is_Child_Unit
(Pent
)
2377 Pent
:= Scope
(Pent
);
2380 -- Special case Standard and Standard.ASCII
2382 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2384 Make_String_Literal
(Loc
,
2385 Strval
=> Verbose_Library_Version
));
2390 -- Build required string constant
2392 Get_Name_String
(Get_Unit_Name
(Pent
));
2395 for J
in 1 .. Name_Len
- 2 loop
2396 if Name_Buffer
(J
) = '.' then
2397 Store_String_Chars
("__");
2399 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2403 -- Case of subprogram acting as its own spec, always use body
2405 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2406 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2408 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2410 Store_String_Chars
("B");
2412 -- Case of no body present, always use spec
2414 elsif not Unit_Requires_Body
(Pent
) then
2415 Store_String_Chars
("S");
2417 -- Otherwise use B for Body_Version, S for spec
2419 elsif Id
= Attribute_Body_Version
then
2420 Store_String_Chars
("B");
2422 Store_String_Chars
("S");
2426 Lib
.Version_Referenced
(S
);
2428 -- Insert the object declaration
2430 Insert_Actions
(N
, New_List
(
2431 Make_Object_Declaration
(Loc
,
2432 Defining_Identifier
=> E
,
2433 Object_Definition
=>
2434 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2436 -- Set entity as imported with correct external name
2438 Set_Is_Imported
(E
);
2439 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2441 -- Set entity as internal to ensure proper Sprint output of its
2442 -- implicit importation.
2444 Set_Is_Internal
(E
);
2446 -- And now rewrite original reference
2449 Make_Function_Call
(Loc
,
2451 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2452 Parameter_Associations
=> New_List
(
2453 New_Occurrence_Of
(E
, Loc
))));
2456 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2463 -- Transforms 'Ceiling into a call to the floating-point attribute
2464 -- function Ceiling in Fat_xxx (where xxx is the root type)
2466 when Attribute_Ceiling
=>
2467 Expand_Fpt_Attribute_R
(N
);
2473 -- Transforms 'Callable attribute into a call to the Callable function
2475 when Attribute_Callable
=>
2476 -- We have an object of a task interface class-wide type as a prefix
2477 -- to Callable. Generate:
2478 -- callable (Task_Id (Pref._disp_get_task_id));
2480 if Ada_Version
>= Ada_2005
2481 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2482 and then Is_Interface
(Ptyp
)
2483 and then Is_Task_Interface
(Ptyp
)
2486 Make_Function_Call
(Loc
,
2488 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2489 Parameter_Associations
=> New_List
(
2490 Make_Unchecked_Type_Conversion
(Loc
,
2492 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2494 Make_Selected_Component
(Loc
,
2496 New_Copy_Tree
(Pref
),
2498 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
2502 Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2505 Analyze_And_Resolve
(N
, Standard_Boolean
);
2511 -- Transforms 'Caller attribute into a call to either the
2512 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2514 when Attribute_Caller
=> Caller
: declare
2515 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2516 Ent
: constant Entity_Id
:= Entity
(Pref
);
2517 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2518 Nest_Depth
: Integer := 0;
2525 if Is_Protected_Type
(Conctype
) then
2526 case Corresponding_Runtime_Package
(Conctype
) is
2527 when System_Tasking_Protected_Objects_Entries
=>
2530 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2532 when System_Tasking_Protected_Objects_Single_Entry
=>
2535 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2538 raise Program_Error
;
2542 Unchecked_Convert_To
(Id_Kind
,
2543 Make_Function_Call
(Loc
,
2545 Parameter_Associations
=> New_List
(
2547 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2552 -- Determine the nesting depth of the E'Caller attribute, that
2553 -- is, how many accept statements are nested within the accept
2554 -- statement for E at the point of E'Caller. The runtime uses
2555 -- this depth to find the specified entry call.
2557 for J
in reverse 0 .. Scope_Stack
.Last
loop
2558 S
:= Scope_Stack
.Table
(J
).Entity
;
2560 -- We should not reach the scope of the entry, as it should
2561 -- already have been checked in Sem_Attr that this attribute
2562 -- reference is within a matching accept statement.
2564 pragma Assert
(S
/= Conctype
);
2569 elsif Is_Entry
(S
) then
2570 Nest_Depth
:= Nest_Depth
+ 1;
2575 Unchecked_Convert_To
(Id_Kind
,
2576 Make_Function_Call
(Loc
,
2578 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2579 Parameter_Associations
=> New_List
(
2580 Make_Integer_Literal
(Loc
,
2581 Intval
=> Int
(Nest_Depth
))))));
2584 Analyze_And_Resolve
(N
, Id_Kind
);
2591 -- Transforms 'Compose into a call to the floating-point attribute
2592 -- function Compose in Fat_xxx (where xxx is the root type)
2594 -- Note: we strictly should have special code here to deal with the
2595 -- case of absurdly negative arguments (less than Integer'First)
2596 -- which will return a (signed) zero value, but it hardly seems
2597 -- worth the effort. Absurdly large positive arguments will raise
2598 -- constraint error which is fine.
2600 when Attribute_Compose
=>
2601 Expand_Fpt_Attribute_RI
(N
);
2607 when Attribute_Constrained
=> Constrained
: declare
2608 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2610 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2611 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2612 -- view of an aliased object whose subtype is constrained.
2614 ---------------------------------
2615 -- Is_Constrained_Aliased_View --
2616 ---------------------------------
2618 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2622 if Is_Entity_Name
(Obj
) then
2625 if Present
(Renamed_Object
(E
)) then
2626 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2628 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2632 return Is_Aliased_View
(Obj
)
2634 (Is_Constrained
(Etype
(Obj
))
2636 (Nkind
(Obj
) = N_Explicit_Dereference
2638 not Object_Type_Has_Constrained_Partial_View
2639 (Typ
=> Base_Type
(Etype
(Obj
)),
2640 Scop
=> Current_Scope
)));
2642 end Is_Constrained_Aliased_View
;
2644 -- Start of processing for Constrained
2647 -- Reference to a parameter where the value is passed as an extra
2648 -- actual, corresponding to the extra formal referenced by the
2649 -- Extra_Constrained field of the corresponding formal. If this
2650 -- is an entry in-parameter, it is replaced by a constant renaming
2651 -- for which Extra_Constrained is never created.
2653 if Present
(Formal_Ent
)
2654 and then Ekind
(Formal_Ent
) /= E_Constant
2655 and then Present
(Extra_Constrained
(Formal_Ent
))
2659 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2661 -- For variables with a Extra_Constrained field, we use the
2662 -- corresponding entity.
2664 elsif Nkind
(Pref
) = N_Identifier
2665 and then Ekind
(Entity
(Pref
)) = E_Variable
2666 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2670 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2672 -- For all other entity names, we can tell at compile time
2674 elsif Is_Entity_Name
(Pref
) then
2676 Ent
: constant Entity_Id
:= Entity
(Pref
);
2680 -- (RM J.4) obsolescent cases
2682 if Is_Type
(Ent
) then
2686 if Is_Private_Type
(Ent
) then
2687 Res
:= not Has_Discriminants
(Ent
)
2688 or else Is_Constrained
(Ent
);
2690 -- It not a private type, must be a generic actual type
2691 -- that corresponded to a private type. We know that this
2692 -- correspondence holds, since otherwise the reference
2693 -- within the generic template would have been illegal.
2696 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2697 Res
:= Is_Constrained
(Ent
);
2704 -- For access type, apply access check as needed
2706 if Is_Access_Type
(Ptyp
) then
2707 Apply_Access_Check
(N
);
2710 -- If the prefix is not a variable or is aliased, then
2711 -- definitely true; if it's a formal parameter without an
2712 -- associated extra formal, then treat it as constrained.
2714 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2715 -- constrained in order to set the attribute to True.
2717 if not Is_Variable
(Pref
)
2718 or else Present
(Formal_Ent
)
2719 or else (Ada_Version
< Ada_2005
2720 and then Is_Aliased_View
(Pref
))
2721 or else (Ada_Version
>= Ada_2005
2722 and then Is_Constrained_Aliased_View
(Pref
))
2726 -- Variable case, look at type to see if it is constrained.
2727 -- Note that the one case where this is not accurate (the
2728 -- procedure formal case), has been handled above.
2730 -- We use the Underlying_Type here (and below) in case the
2731 -- type is private without discriminants, but the full type
2732 -- has discriminants. This case is illegal, but we generate
2733 -- it internally for passing to the Extra_Constrained
2737 -- In Ada 2012, test for case of a limited tagged type,
2738 -- in which case the attribute is always required to
2739 -- return True. The underlying type is tested, to make
2740 -- sure we also return True for cases where there is an
2741 -- unconstrained object with an untagged limited partial
2742 -- view which has defaulted discriminants (such objects
2743 -- always produce a False in earlier versions of
2744 -- Ada). (Ada 2012: AI05-0214)
2747 Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2749 (Ada_Version
>= Ada_2012
2750 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2751 and then Is_Limited_Type
(Ptyp
));
2755 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Res
), Loc
));
2758 -- Prefix is not an entity name. These are also cases where we can
2759 -- always tell at compile time by looking at the form and type of the
2760 -- prefix. If an explicit dereference of an object with constrained
2761 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2762 -- underlying type is a limited tagged type, then Constrained is
2763 -- required to always return True (Ada 2012: AI05-0214).
2769 not Is_Variable
(Pref
)
2771 (Nkind
(Pref
) = N_Explicit_Dereference
2773 not Object_Type_Has_Constrained_Partial_View
2774 (Typ
=> Base_Type
(Ptyp
),
2775 Scop
=> Current_Scope
))
2776 or else Is_Constrained
(Underlying_Type
(Ptyp
))
2777 or else (Ada_Version
>= Ada_2012
2778 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2779 and then Is_Limited_Type
(Ptyp
))),
2783 Analyze_And_Resolve
(N
, Standard_Boolean
);
2790 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2791 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2793 when Attribute_Copy_Sign
=>
2794 Expand_Fpt_Attribute_RR
(N
);
2800 -- Transforms 'Count attribute into a call to the Count function
2802 when Attribute_Count
=> Count
: declare
2804 Conctyp
: Entity_Id
;
2806 Entry_Id
: Entity_Id
;
2811 -- If the prefix is a member of an entry family, retrieve both
2812 -- entry name and index. For a simple entry there is no index.
2814 if Nkind
(Pref
) = N_Indexed_Component
then
2815 Entnam
:= Prefix
(Pref
);
2816 Index
:= First
(Expressions
(Pref
));
2822 Entry_Id
:= Entity
(Entnam
);
2824 -- Find the concurrent type in which this attribute is referenced
2825 -- (there had better be one).
2827 Conctyp
:= Current_Scope
;
2828 while not Is_Concurrent_Type
(Conctyp
) loop
2829 Conctyp
:= Scope
(Conctyp
);
2834 if Is_Protected_Type
(Conctyp
) then
2835 case Corresponding_Runtime_Package
(Conctyp
) is
2836 when System_Tasking_Protected_Objects_Entries
=>
2837 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
2840 Make_Function_Call
(Loc
,
2842 Parameter_Associations
=> New_List
(
2844 (Find_Protection_Object
(Current_Scope
), Loc
),
2845 Entry_Index_Expression
2846 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2848 when System_Tasking_Protected_Objects_Single_Entry
=>
2850 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
2853 Make_Function_Call
(Loc
,
2855 Parameter_Associations
=> New_List
(
2857 (Find_Protection_Object
(Current_Scope
), Loc
)));
2860 raise Program_Error
;
2867 Make_Function_Call
(Loc
,
2868 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
2869 Parameter_Associations
=> New_List
(
2870 Entry_Index_Expression
(Loc
,
2871 Entry_Id
, Index
, Scope
(Entry_Id
))));
2874 -- The call returns type Natural but the context is universal integer
2875 -- so any integer type is allowed. The attribute was already resolved
2876 -- so its Etype is the required result type. If the base type of the
2877 -- context type is other than Standard.Integer we put in a conversion
2878 -- to the required type. This can be a normal typed conversion since
2879 -- both input and output types of the conversion are integer types
2881 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2882 Rewrite
(N
, Convert_To
(Typ
, Call
));
2887 Analyze_And_Resolve
(N
, Typ
);
2890 ---------------------
2891 -- Descriptor_Size --
2892 ---------------------
2894 when Attribute_Descriptor_Size
=>
2896 -- Attribute Descriptor_Size is handled by the back end when applied
2897 -- to an unconstrained array type.
2899 if Is_Array_Type
(Ptyp
)
2900 and then not Is_Constrained
(Ptyp
)
2902 Apply_Universal_Integer_Attribute_Checks
(N
);
2904 -- For any other type, the descriptor size is 0 because there is no
2905 -- actual descriptor, but the result is not formally static.
2908 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2910 Set_Is_Static_Expression
(N
, False);
2917 -- This processing is shared by Elab_Spec
2919 -- What we do is to insert the following declarations
2922 -- pragma Import (C, enn, "name___elabb/s");
2924 -- and then the Elab_Body/Spec attribute is replaced by a reference
2925 -- to this defining identifier.
2927 when Attribute_Elab_Body
2928 | Attribute_Elab_Spec
2930 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2931 -- back-end knows how to handle these attributes directly.
2933 if CodePeer_Mode
then
2938 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
2942 procedure Make_Elab_String
(Nod
: Node_Id
);
2943 -- Given Nod, an identifier, or a selected component, put the
2944 -- image into the current string literal, with double underline
2945 -- between components.
2947 ----------------------
2948 -- Make_Elab_String --
2949 ----------------------
2951 procedure Make_Elab_String
(Nod
: Node_Id
) is
2953 if Nkind
(Nod
) = N_Selected_Component
then
2954 Make_Elab_String
(Prefix
(Nod
));
2955 Store_String_Char
('_');
2956 Store_String_Char
('_');
2957 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
2960 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
2961 Get_Name_String
(Chars
(Nod
));
2964 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2965 end Make_Elab_String
;
2967 -- Start of processing for Elab_Body/Elab_Spec
2970 -- First we need to prepare the string literal for the name of
2971 -- the elaboration routine to be referenced.
2974 Make_Elab_String
(Pref
);
2975 Store_String_Chars
("___elab");
2976 Lang
:= Make_Identifier
(Loc
, Name_C
);
2978 if Id
= Attribute_Elab_Body
then
2979 Store_String_Char
('b');
2981 Store_String_Char
('s');
2986 Insert_Actions
(N
, New_List
(
2987 Make_Subprogram_Declaration
(Loc
,
2989 Make_Procedure_Specification
(Loc
,
2990 Defining_Unit_Name
=> Ent
)),
2993 Chars
=> Name_Import
,
2994 Pragma_Argument_Associations
=> New_List
(
2995 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
2997 Make_Pragma_Argument_Association
(Loc
,
2998 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3000 Make_Pragma_Argument_Association
(Loc
,
3001 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3003 Set_Entity
(N
, Ent
);
3004 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3007 --------------------
3008 -- Elab_Subp_Body --
3009 --------------------
3011 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3012 -- this attribute directly, and if we are not in CodePeer mode it is
3013 -- entirely ignored ???
3015 when Attribute_Elab_Subp_Body
=>
3022 -- Elaborated is always True for preelaborated units, predefined units,
3023 -- pure units and units which have Elaborate_Body pragmas. These units
3024 -- have no elaboration entity.
3026 -- Note: The Elaborated attribute is never passed to the back end
3028 when Attribute_Elaborated
=> Elaborated
: declare
3029 Ent
: constant Entity_Id
:= Entity
(Pref
);
3032 if Present
(Elaboration_Entity
(Ent
)) then
3036 New_Occurrence_Of
(Elaboration_Entity
(Ent
), Loc
),
3038 Make_Integer_Literal
(Loc
, Uint_0
)));
3039 Analyze_And_Resolve
(N
, Typ
);
3041 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3049 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3053 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3056 if Is_Non_Empty_List
(Exprs
) then
3057 Expr
:= First
(Exprs
);
3062 -- If the expression is an enumeration literal, it is replaced by the
3065 if Nkind
(Expr
) in N_Has_Entity
3066 and then Ekind
(Entity
(Expr
)) = E_Enumeration_Literal
3069 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Expr
))));
3071 -- If this is a renaming of a literal, recover the representation
3072 -- of the original. If it renames an expression there is nothing to
3075 elsif Nkind
(Expr
) in N_Has_Entity
3076 and then Ekind
(Entity
(Expr
)) = E_Constant
3077 and then Present
(Renamed_Object
(Entity
(Expr
)))
3078 and then Is_Entity_Name
(Renamed_Object
(Entity
(Expr
)))
3079 and then Ekind
(Entity
(Renamed_Object
(Entity
(Expr
)))) =
3080 E_Enumeration_Literal
3083 Make_Integer_Literal
(Loc
,
3084 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Expr
))))));
3086 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3087 -- X'Enum_Rep expands to
3091 -- This is simply a direct conversion from the enumeration type to
3092 -- the target integer type, which is treated by the back end as a
3093 -- normal integer conversion, treating the enumeration type as an
3094 -- integer, which is exactly what we want. We set Conversion_OK to
3095 -- make sure that the analyzer does not complain about what otherwise
3096 -- might be an illegal conversion.
3099 Rewrite
(N
, OK_Convert_To
(Typ
, Relocate_Node
(Expr
)));
3103 Analyze_And_Resolve
(N
, Typ
);
3110 when Attribute_Enum_Val
=> Enum_Val
: declare
3112 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3115 -- X'Enum_Val (Y) expands to
3117 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3120 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3123 Make_Raise_Constraint_Error
(Loc
,
3127 Make_Function_Call
(Loc
,
3129 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3130 Parameter_Associations
=> New_List
(
3131 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3132 New_Occurrence_Of
(Standard_False
, Loc
))),
3134 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3135 Reason
=> CE_Range_Check_Failed
));
3138 Analyze_And_Resolve
(N
, Ptyp
);
3145 -- Transforms 'Exponent into a call to the floating-point attribute
3146 -- function Exponent in Fat_xxx (where xxx is the root type)
3148 when Attribute_Exponent
=>
3149 Expand_Fpt_Attribute_R
(N
);
3155 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3157 when Attribute_External_Tag
=>
3159 Make_Function_Call
(Loc
,
3161 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3162 Parameter_Associations
=> New_List
(
3163 Make_Attribute_Reference
(Loc
,
3164 Attribute_Name
=> Name_Tag
,
3165 Prefix
=> Prefix
(N
)))));
3167 Analyze_And_Resolve
(N
, Standard_String
);
3169 -----------------------
3170 -- Finalization_Size --
3171 -----------------------
3173 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3174 function Calculate_Header_Size
return Node_Id
;
3175 -- Generate a runtime call to calculate the size of the hidden header
3176 -- along with any added padding which would precede a heap-allocated
3177 -- object of the prefix type.
3179 ---------------------------
3180 -- Calculate_Header_Size --
3181 ---------------------------
3183 function Calculate_Header_Size
return Node_Id
is
3186 -- Universal_Integer
3187 -- (Header_Size_With_Padding (Pref'Alignment))
3190 Convert_To
(Universal_Integer
,
3191 Make_Function_Call
(Loc
,
3193 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3195 Parameter_Associations
=> New_List
(
3196 Make_Attribute_Reference
(Loc
,
3197 Prefix
=> New_Copy_Tree
(Pref
),
3198 Attribute_Name
=> Name_Alignment
))));
3199 end Calculate_Header_Size
;
3205 -- Start of Finalization_Size
3208 -- An object of a class-wide type first requires a runtime check to
3209 -- determine whether it is actually controlled or not. Depending on
3210 -- the outcome of this check, the Finalization_Size of the object
3211 -- may be zero or some positive value.
3213 -- In this scenario, Pref'Finalization_Size is expanded into
3215 -- Size : Integer := 0;
3217 -- if Needs_Finalization (Pref'Tag) then
3219 -- Universal_Integer
3220 -- (Header_Size_With_Padding (Pref'Alignment));
3223 -- and the attribute reference is replaced with a reference to Size.
3225 if Is_Class_Wide_Type
(Ptyp
) then
3226 Size
:= Make_Temporary
(Loc
, 'S');
3228 Insert_Actions
(N
, New_List
(
3231 -- Size : Integer := 0;
3233 Make_Object_Declaration
(Loc
,
3234 Defining_Identifier
=> Size
,
3235 Object_Definition
=>
3236 New_Occurrence_Of
(Standard_Integer
, Loc
),
3237 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3240 -- if Needs_Finalization (Pref'Tag) then
3242 -- Universal_Integer
3243 -- (Header_Size_With_Padding (Pref'Alignment));
3246 Make_If_Statement
(Loc
,
3248 Make_Function_Call
(Loc
,
3250 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3252 Parameter_Associations
=> New_List
(
3253 Make_Attribute_Reference
(Loc
,
3254 Prefix
=> New_Copy_Tree
(Pref
),
3255 Attribute_Name
=> Name_Tag
))),
3257 Then_Statements
=> New_List
(
3258 Make_Assignment_Statement
(Loc
,
3259 Name
=> New_Occurrence_Of
(Size
, Loc
),
3260 Expression
=> Calculate_Header_Size
)))));
3262 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3264 -- The prefix is known to be controlled at compile time. Calculate
3265 -- Finalization_Size by calling function Header_Size_With_Padding.
3267 elsif Needs_Finalization
(Ptyp
) then
3268 Rewrite
(N
, Calculate_Header_Size
);
3270 -- The prefix is not an object with controlled parts, so its
3271 -- Finalization_Size is zero.
3274 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3277 -- Due to cases where the entity type of the attribute is already
3278 -- resolved the rewritten N must get re-resolved to its appropriate
3281 Analyze_And_Resolve
(N
, Typ
);
3282 end Finalization_Size
;
3288 when Attribute_First
=>
3290 -- If the prefix type is a constrained packed array type which
3291 -- already has a Packed_Array_Impl_Type representation defined, then
3292 -- replace this attribute with a direct reference to 'First of the
3293 -- appropriate index subtype (since otherwise the back end will try
3294 -- to give us the value of 'First for this implementation type).
3296 if Is_Constrained_Packed_Array
(Ptyp
) then
3298 Make_Attribute_Reference
(Loc
,
3299 Attribute_Name
=> Name_First
,
3301 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3302 Analyze_And_Resolve
(N
, Typ
);
3304 -- For access type, apply access check as needed
3306 elsif Is_Access_Type
(Ptyp
) then
3307 Apply_Access_Check
(N
);
3309 -- For scalar type, if low bound is a reference to an entity, just
3310 -- replace with a direct reference. Note that we can only have a
3311 -- reference to a constant entity at this stage, anything else would
3312 -- have already been rewritten.
3314 elsif Is_Scalar_Type
(Ptyp
) then
3316 Lo
: constant Node_Id
:= Type_Low_Bound
(Ptyp
);
3318 if Is_Entity_Name
(Lo
) then
3319 Rewrite
(N
, New_Occurrence_Of
(Entity
(Lo
), Loc
));
3328 -- Compute this if component clause was present, otherwise we leave the
3329 -- computation to be completed in the back-end, since we don't know what
3330 -- layout will be chosen.
3332 when Attribute_First_Bit
=> First_Bit_Attr
: declare
3333 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3336 -- In Ada 2005 (or later) if we have the non-default bit order, then
3337 -- we return the original value as given in the component clause
3338 -- (RM 2005 13.5.2(3/2)).
3340 if Present
(Component_Clause
(CE
))
3341 and then Ada_Version
>= Ada_2005
3342 and then Reverse_Bit_Order
(Scope
(CE
))
3345 Make_Integer_Literal
(Loc
,
3346 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
3347 Analyze_And_Resolve
(N
, Typ
);
3349 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3350 -- rewrite with normalized value if we know it statically.
3352 elsif Known_Static_Component_Bit_Offset
(CE
) then
3354 Make_Integer_Literal
(Loc
,
3355 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
3356 Analyze_And_Resolve
(N
, Typ
);
3358 -- Otherwise left to back end, just do universal integer checks
3361 Apply_Universal_Integer_Attribute_Checks
(N
);
3371 -- fixtype'Fixed_Value (integer-value)
3375 -- fixtype(integer-value)
3377 -- We do all the required analysis of the conversion here, because we do
3378 -- not want this to go through the fixed-point conversion circuits. Note
3379 -- that the back end always treats fixed-point as equivalent to the
3380 -- corresponding integer type anyway.
3382 when Attribute_Fixed_Value
=>
3384 Make_Type_Conversion
(Loc
,
3385 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3386 Expression
=> Relocate_Node
(First
(Exprs
))));
3387 Set_Etype
(N
, Entity
(Pref
));
3390 -- Note: it might appear that a properly analyzed unchecked
3391 -- conversion would be just fine here, but that's not the case,
3392 -- since the full range checks performed by the following call
3395 Apply_Type_Conversion_Checks
(N
);
3401 -- Transforms 'Floor into a call to the floating-point attribute
3402 -- function Floor in Fat_xxx (where xxx is the root type)
3404 when Attribute_Floor
=>
3405 Expand_Fpt_Attribute_R
(N
);
3411 -- For the fixed-point type Typ:
3417 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3418 -- Universal_Real (Type'Last))
3420 -- Note that we know that the type is a non-static subtype, or Fore
3421 -- would have itself been computed dynamically in Eval_Attribute.
3423 when Attribute_Fore
=>
3426 Make_Function_Call
(Loc
,
3428 New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
3430 Parameter_Associations
=> New_List
(
3431 Convert_To
(Universal_Real
,
3432 Make_Attribute_Reference
(Loc
,
3433 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3434 Attribute_Name
=> Name_First
)),
3436 Convert_To
(Universal_Real
,
3437 Make_Attribute_Reference
(Loc
,
3438 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3439 Attribute_Name
=> Name_Last
))))));
3441 Analyze_And_Resolve
(N
, Typ
);
3447 -- Transforms 'Fraction into a call to the floating-point attribute
3448 -- function Fraction in Fat_xxx (where xxx is the root type)
3450 when Attribute_Fraction
=>
3451 Expand_Fpt_Attribute_R
(N
);
3457 when Attribute_From_Any
=> From_Any
: declare
3458 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3459 Decls
: constant List_Id
:= New_List
;
3463 Build_From_Any_Call
(P_Type
,
3464 Relocate_Node
(First
(Exprs
)),
3466 Insert_Actions
(N
, Decls
);
3467 Analyze_And_Resolve
(N
, P_Type
);
3470 ----------------------
3471 -- Has_Same_Storage --
3472 ----------------------
3474 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3475 Loc
: constant Source_Ptr
:= Sloc
(N
);
3477 X
: constant Node_Id
:= Prefix
(N
);
3478 Y
: constant Node_Id
:= First
(Expressions
(N
));
3483 -- Rhe expressions for their addresses
3487 -- Rhe expressions for their sizes
3490 -- The attribute is expanded as:
3492 -- (X'address = Y'address)
3493 -- and then (X'Size = Y'Size)
3495 -- If both arguments have the same Etype the second conjunct can be
3499 Make_Attribute_Reference
(Loc
,
3500 Attribute_Name
=> Name_Address
,
3501 Prefix
=> New_Copy_Tree
(X
));
3504 Make_Attribute_Reference
(Loc
,
3505 Attribute_Name
=> Name_Address
,
3506 Prefix
=> New_Copy_Tree
(Y
));
3509 Make_Attribute_Reference
(Loc
,
3510 Attribute_Name
=> Name_Size
,
3511 Prefix
=> New_Copy_Tree
(X
));
3514 Make_Attribute_Reference
(Loc
,
3515 Attribute_Name
=> Name_Size
,
3516 Prefix
=> New_Copy_Tree
(Y
));
3518 if Etype
(X
) = Etype
(Y
) then
3521 Left_Opnd
=> X_Addr
,
3522 Right_Opnd
=> Y_Addr
));
3528 Left_Opnd
=> X_Addr
,
3529 Right_Opnd
=> Y_Addr
),
3532 Left_Opnd
=> X_Size
,
3533 Right_Opnd
=> Y_Size
)));
3536 Analyze_And_Resolve
(N
, Standard_Boolean
);
3537 end Has_Same_Storage
;
3543 -- For an exception returns a reference to the exception data:
3544 -- Exception_Id!(Prefix'Reference)
3546 -- For a task it returns a reference to the _task_id component of
3547 -- corresponding record:
3549 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3551 -- in Ada.Task_Identification
3553 when Attribute_Identity
=> Identity
: declare
3554 Id_Kind
: Entity_Id
;
3557 if Ptyp
= Standard_Exception_Type
then
3558 Id_Kind
:= RTE
(RE_Exception_Id
);
3560 if Present
(Renamed_Object
(Entity
(Pref
))) then
3561 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3565 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3567 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3569 -- If the prefix is a task interface, the Task_Id is obtained
3570 -- dynamically through a dispatching call, as for other task
3571 -- attributes applied to interfaces.
3573 if Ada_Version
>= Ada_2005
3574 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3575 and then Is_Interface
(Ptyp
)
3576 and then Is_Task_Interface
(Ptyp
)
3579 Unchecked_Convert_To
(Id_Kind
,
3580 Make_Selected_Component
(Loc
,
3582 New_Copy_Tree
(Pref
),
3584 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))));
3588 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3592 Analyze_And_Resolve
(N
, Id_Kind
);
3599 -- Image attribute is handled in separate unit Exp_Imgv
3601 when Attribute_Image
=>
3602 Exp_Imgv
.Expand_Image_Attribute
(N
);
3608 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3610 when Attribute_Img
=>
3612 Make_Attribute_Reference
(Loc
,
3613 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3614 Attribute_Name
=> Name_Image
,
3615 Expressions
=> New_List
(Relocate_Node
(Pref
))));
3617 Analyze_And_Resolve
(N
, Standard_String
);
3623 when Attribute_Input
=> Input
: declare
3624 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3625 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3626 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3627 Strm
: constant Node_Id
:= First
(Exprs
);
3635 Cntrl
: Node_Id
:= Empty
;
3636 -- Value for controlling argument in call. Always Empty except in
3637 -- the dispatching (class-wide type) case, where it is a reference
3638 -- to the dummy object initialized to the right internal tag.
3640 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3641 -- The expansion of the attribute reference may generate a call to
3642 -- a user-defined stream subprogram that is frozen by the call. This
3643 -- can lead to access-before-elaboration problem if the reference
3644 -- appears in an object declaration and the subprogram body has not
3645 -- been seen. The freezing of the subprogram requires special code
3646 -- because it appears in an expanded context where expressions do
3647 -- not freeze their constituents.
3649 ------------------------------
3650 -- Freeze_Stream_Subprogram --
3651 ------------------------------
3653 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3654 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3658 -- If this is user-defined subprogram, the corresponding
3659 -- stream function appears as a renaming-as-body, and the
3660 -- user subprogram must be retrieved by tree traversal.
3663 and then Nkind
(Decl
) = N_Subprogram_Declaration
3664 and then Present
(Corresponding_Body
(Decl
))
3666 Bod
:= Corresponding_Body
(Decl
);
3668 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3669 N_Subprogram_Renaming_Declaration
3671 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3674 end Freeze_Stream_Subprogram
;
3676 -- Start of processing for Input
3679 -- If no underlying type, we have an error that will be diagnosed
3680 -- elsewhere, so here we just completely ignore the expansion.
3686 -- Stream operations can appear in user code even if the restriction
3687 -- No_Streams is active (for example, when instantiating a predefined
3688 -- container). In that case rewrite the attribute as a Raise to
3689 -- prevent any run-time use.
3691 if Restriction_Active
(No_Streams
) then
3693 Make_Raise_Program_Error
(Sloc
(N
),
3694 Reason
=> PE_Stream_Operation_Not_Allowed
));
3695 Set_Etype
(N
, B_Type
);
3699 -- If there is a TSS for Input, just call it
3701 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3703 if Present
(Fname
) then
3707 -- If there is a Stream_Convert pragma, use it, we rewrite
3709 -- sourcetyp'Input (stream)
3713 -- sourcetyp (streamread (strmtyp'Input (stream)));
3715 -- where streamread is the given Read function that converts an
3716 -- argument of type strmtyp to type sourcetyp or a type from which
3717 -- it is derived (extra conversion required for the derived case).
3719 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3721 if Present
(Prag
) then
3722 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3723 Rfunc
:= Entity
(Expression
(Arg2
));
3727 Make_Function_Call
(Loc
,
3728 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3729 Parameter_Associations
=> New_List
(
3730 Make_Attribute_Reference
(Loc
,
3733 (Etype
(First_Formal
(Rfunc
)), Loc
),
3734 Attribute_Name
=> Name_Input
,
3735 Expressions
=> Exprs
)))));
3737 Analyze_And_Resolve
(N
, B_Type
);
3742 elsif Is_Elementary_Type
(U_Type
) then
3744 -- A special case arises if we have a defined _Read routine,
3745 -- since in this case we are required to call this routine.
3748 Typ
: Entity_Id
:= P_Type
;
3750 if Present
(Full_View
(Typ
)) then
3751 Typ
:= Full_View
(Typ
);
3754 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Read
)) then
3755 Build_Record_Or_Elementary_Input_Function
3756 (Loc
, Typ
, Decl
, Fname
, Use_Underlying
=> False);
3757 Insert_Action
(N
, Decl
);
3759 -- For normal cases, we call the I_xxx routine directly
3762 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3763 Analyze_And_Resolve
(N
, P_Type
);
3770 elsif Is_Array_Type
(U_Type
) then
3771 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3772 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3774 -- Dispatching case with class-wide type
3776 elsif Is_Class_Wide_Type
(P_Type
) then
3778 -- No need to do anything else compiling under restriction
3779 -- No_Dispatching_Calls. During the semantic analysis we
3780 -- already notified such violation.
3782 if Restriction_Active
(No_Dispatching_Calls
) then
3787 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3791 -- Read the internal tag (RM 13.13.2(34)) and use it to
3792 -- initialize a dummy tag value:
3794 -- Descendant_Tag (String'Input (Strm), P_Type);
3796 -- This value is used only to provide a controlling
3797 -- argument for the eventual _Input call. Descendant_Tag is
3798 -- called rather than Internal_Tag to ensure that we have a
3799 -- tag for a type that is descended from the prefix type and
3800 -- declared at the same accessibility level (the exception
3801 -- Tag_Error will be raised otherwise). The level check is
3802 -- required for Ada 2005 because tagged types can be
3803 -- extended in nested scopes (AI-344).
3805 -- Note: we used to generate an explicit declaration of a
3806 -- constant Ada.Tags.Tag object, and use an occurrence of
3807 -- this constant in Cntrl, but this caused a secondary stack
3811 Make_Function_Call
(Loc
,
3813 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3814 Parameter_Associations
=> New_List
(
3815 Make_Attribute_Reference
(Loc
,
3817 New_Occurrence_Of
(Standard_String
, Loc
),
3818 Attribute_Name
=> Name_Input
,
3819 Expressions
=> New_List
(
3820 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
3821 Make_Attribute_Reference
(Loc
,
3822 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
3823 Attribute_Name
=> Name_Tag
)));
3824 Set_Etype
(Expr
, RTE
(RE_Tag
));
3826 -- Now we need to get the entity for the call, and construct
3827 -- a function call node, where we preset a reference to Dnn
3828 -- as the controlling argument (doing an unchecked convert
3829 -- to the class-wide tagged type to make it look like a real
3832 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3833 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
3834 Set_Etype
(Cntrl
, P_Type
);
3835 Set_Parent
(Cntrl
, N
);
3838 -- For tagged types, use the primitive Input function
3840 elsif Is_Tagged_Type
(U_Type
) then
3841 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3843 -- All other record type cases, including protected records. The
3844 -- latter only arise for expander generated code for handling
3845 -- shared passive partition access.
3849 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3851 -- Ada 2005 (AI-216): Program_Error is raised executing default
3852 -- implementation of the Input attribute of an unchecked union
3853 -- type if the type lacks default discriminant values.
3855 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3856 and then No
(Discriminant_Constraint
(U_Type
))
3859 Make_Raise_Program_Error
(Loc
,
3860 Reason
=> PE_Unchecked_Union_Restriction
));
3865 -- Build the type's Input function, passing the subtype rather
3866 -- than its base type, because checks are needed in the case of
3867 -- constrained discriminants (see Ada 2012 AI05-0192).
3869 Build_Record_Or_Elementary_Input_Function
3870 (Loc
, U_Type
, Decl
, Fname
);
3871 Insert_Action
(N
, Decl
);
3873 if Nkind
(Parent
(N
)) = N_Object_Declaration
3874 and then Is_Record_Type
(U_Type
)
3876 -- The stream function may contain calls to user-defined
3877 -- Read procedures for individual components.
3884 Comp
:= First_Component
(U_Type
);
3885 while Present
(Comp
) loop
3887 Find_Stream_Subprogram
3888 (Etype
(Comp
), TSS_Stream_Read
);
3890 if Present
(Func
) then
3891 Freeze_Stream_Subprogram
(Func
);
3894 Next_Component
(Comp
);
3901 -- If we fall through, Fname is the function to be called. The result
3902 -- is obtained by calling the appropriate function, then converting
3903 -- the result. The conversion does a subtype check.
3906 Make_Function_Call
(Loc
,
3907 Name
=> New_Occurrence_Of
(Fname
, Loc
),
3908 Parameter_Associations
=> New_List
(
3909 Relocate_Node
(Strm
)));
3911 Set_Controlling_Argument
(Call
, Cntrl
);
3912 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
3913 Analyze_And_Resolve
(N
, P_Type
);
3915 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
3916 Freeze_Stream_Subprogram
(Fname
);
3926 -- inttype'Fixed_Value (fixed-value)
3930 -- inttype(integer-value))
3932 -- we do all the required analysis of the conversion here, because we do
3933 -- not want this to go through the fixed-point conversion circuits. Note
3934 -- that the back end always treats fixed-point as equivalent to the
3935 -- corresponding integer type anyway.
3937 when Attribute_Integer_Value
=>
3939 Make_Type_Conversion
(Loc
,
3940 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3941 Expression
=> Relocate_Node
(First
(Exprs
))));
3942 Set_Etype
(N
, Entity
(Pref
));
3945 -- Note: it might appear that a properly analyzed unchecked
3946 -- conversion would be just fine here, but that's not the case, since
3947 -- the full range check performed by the following call is critical.
3949 Apply_Type_Conversion_Checks
(N
);
3955 when Attribute_Invalid_Value
=>
3956 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
3962 when Attribute_Last
=>
3964 -- If the prefix type is a constrained packed array type which
3965 -- already has a Packed_Array_Impl_Type representation defined, then
3966 -- replace this attribute with a direct reference to 'Last of the
3967 -- appropriate index subtype (since otherwise the back end will try
3968 -- to give us the value of 'Last for this implementation type).
3970 if Is_Constrained_Packed_Array
(Ptyp
) then
3972 Make_Attribute_Reference
(Loc
,
3973 Attribute_Name
=> Name_Last
,
3974 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3975 Analyze_And_Resolve
(N
, Typ
);
3977 -- For access type, apply access check as needed
3979 elsif Is_Access_Type
(Ptyp
) then
3980 Apply_Access_Check
(N
);
3982 -- For scalar type, if low bound is a reference to an entity, just
3983 -- replace with a direct reference. Note that we can only have a
3984 -- reference to a constant entity at this stage, anything else would
3985 -- have already been rewritten.
3987 elsif Is_Scalar_Type
(Ptyp
) then
3989 Hi
: constant Node_Id
:= Type_High_Bound
(Ptyp
);
3991 if Is_Entity_Name
(Hi
) then
3992 Rewrite
(N
, New_Occurrence_Of
(Entity
(Hi
), Loc
));
4001 -- We compute this if a component clause was present, otherwise we leave
4002 -- the computation up to the back end, since we don't know what layout
4005 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
4006 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4009 -- In Ada 2005 (or later) if we have the non-default bit order, then
4010 -- we return the original value as given in the component clause
4011 -- (RM 2005 13.5.2(3/2)).
4013 if Present
(Component_Clause
(CE
))
4014 and then Ada_Version
>= Ada_2005
4015 and then Reverse_Bit_Order
(Scope
(CE
))
4018 Make_Integer_Literal
(Loc
,
4019 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
4020 Analyze_And_Resolve
(N
, Typ
);
4022 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4023 -- rewrite with normalized value if we know it statically.
4025 elsif Known_Static_Component_Bit_Offset
(CE
)
4026 and then Known_Static_Esize
(CE
)
4029 Make_Integer_Literal
(Loc
,
4030 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
4032 Analyze_And_Resolve
(N
, Typ
);
4034 -- Otherwise leave to back end, just apply universal integer checks
4037 Apply_Universal_Integer_Attribute_Checks
(N
);
4045 -- Transforms 'Leading_Part into a call to the floating-point attribute
4046 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4048 -- Note: strictly, we should generate special case code to deal with
4049 -- absurdly large positive arguments (greater than Integer'Last), which
4050 -- result in returning the first argument unchanged, but it hardly seems
4051 -- worth the effort. We raise constraint error for absurdly negative
4052 -- arguments which is fine.
4054 when Attribute_Leading_Part
=>
4055 Expand_Fpt_Attribute_RI
(N
);
4061 when Attribute_Length
=> Length
: declare
4066 -- Processing for packed array types
4068 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
4069 Ityp
:= Get_Index_Subtype
(N
);
4071 -- If the index type, Ityp, is an enumeration type with holes,
4072 -- then we calculate X'Length explicitly using
4075 -- (0, Ityp'Pos (X'Last (N)) -
4076 -- Ityp'Pos (X'First (N)) + 1);
4078 -- Since the bounds in the template are the representation values
4079 -- and the back end would get the wrong value.
4081 if Is_Enumeration_Type
(Ityp
)
4082 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4087 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4091 Make_Attribute_Reference
(Loc
,
4092 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4093 Attribute_Name
=> Name_Max
,
4094 Expressions
=> New_List
4095 (Make_Integer_Literal
(Loc
, 0),
4099 Make_Op_Subtract
(Loc
,
4101 Make_Attribute_Reference
(Loc
,
4102 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4103 Attribute_Name
=> Name_Pos
,
4105 Expressions
=> New_List
(
4106 Make_Attribute_Reference
(Loc
,
4107 Prefix
=> Duplicate_Subexpr
(Pref
),
4108 Attribute_Name
=> Name_Last
,
4109 Expressions
=> New_List
(
4110 Make_Integer_Literal
(Loc
, Xnum
))))),
4113 Make_Attribute_Reference
(Loc
,
4114 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4115 Attribute_Name
=> Name_Pos
,
4117 Expressions
=> New_List
(
4118 Make_Attribute_Reference
(Loc
,
4120 Duplicate_Subexpr_No_Checks
(Pref
),
4121 Attribute_Name
=> Name_First
,
4122 Expressions
=> New_List
(
4123 Make_Integer_Literal
(Loc
, Xnum
)))))),
4125 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4127 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4130 -- If the prefix type is a constrained packed array type which
4131 -- already has a Packed_Array_Impl_Type representation defined,
4132 -- then replace this attribute with a reference to 'Range_Length
4133 -- of the appropriate index subtype (since otherwise the
4134 -- back end will try to give us the value of 'Length for
4135 -- this implementation type).s
4137 elsif Is_Constrained
(Ptyp
) then
4139 Make_Attribute_Reference
(Loc
,
4140 Attribute_Name
=> Name_Range_Length
,
4141 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4142 Analyze_And_Resolve
(N
, Typ
);
4147 elsif Is_Access_Type
(Ptyp
) then
4148 Apply_Access_Check
(N
);
4150 -- If the designated type is a packed array type, then we convert
4151 -- the reference to:
4154 -- xtyp'Pos (Pref'Last (Expr)) -
4155 -- xtyp'Pos (Pref'First (Expr)));
4157 -- This is a bit complex, but it is the easiest thing to do that
4158 -- works in all cases including enum types with holes xtyp here
4159 -- is the appropriate index type.
4162 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4166 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
4167 Xtyp
:= Get_Index_Subtype
(N
);
4170 Make_Attribute_Reference
(Loc
,
4171 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4172 Attribute_Name
=> Name_Max
,
4173 Expressions
=> New_List
(
4174 Make_Integer_Literal
(Loc
, 0),
4177 Make_Integer_Literal
(Loc
, 1),
4178 Make_Op_Subtract
(Loc
,
4180 Make_Attribute_Reference
(Loc
,
4181 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4182 Attribute_Name
=> Name_Pos
,
4183 Expressions
=> New_List
(
4184 Make_Attribute_Reference
(Loc
,
4185 Prefix
=> Duplicate_Subexpr
(Pref
),
4186 Attribute_Name
=> Name_Last
,
4188 New_Copy_List
(Exprs
)))),
4191 Make_Attribute_Reference
(Loc
,
4192 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4193 Attribute_Name
=> Name_Pos
,
4194 Expressions
=> New_List
(
4195 Make_Attribute_Reference
(Loc
,
4197 Duplicate_Subexpr_No_Checks
(Pref
),
4198 Attribute_Name
=> Name_First
,
4200 New_Copy_List
(Exprs
)))))))));
4202 Analyze_And_Resolve
(N
, Typ
);
4206 -- Otherwise leave it to the back end
4209 Apply_Universal_Integer_Attribute_Checks
(N
);
4213 -- Attribute Loop_Entry is replaced with a reference to a constant value
4214 -- which captures the prefix at the entry point of the related loop. The
4215 -- loop itself may be transformed into a conditional block.
4217 when Attribute_Loop_Entry
=>
4218 Expand_Loop_Entry_Attribute
(N
);
4224 -- Transforms 'Machine into a call to the floating-point attribute
4225 -- function Machine in Fat_xxx (where xxx is the root type).
4226 -- Expansion is avoided for cases the back end can handle directly.
4228 when Attribute_Machine
=>
4229 if not Is_Inline_Floating_Point_Attribute
(N
) then
4230 Expand_Fpt_Attribute_R
(N
);
4233 ----------------------
4234 -- Machine_Rounding --
4235 ----------------------
4237 -- Transforms 'Machine_Rounding into a call to the floating-point
4238 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4239 -- type). Expansion is avoided for cases the back end can handle
4242 when Attribute_Machine_Rounding
=>
4243 if not Is_Inline_Floating_Point_Attribute
(N
) then
4244 Expand_Fpt_Attribute_R
(N
);
4251 -- Machine_Size is equivalent to Object_Size, so transform it into
4252 -- Object_Size and that way the back end never sees Machine_Size.
4254 when Attribute_Machine_Size
=>
4256 Make_Attribute_Reference
(Loc
,
4257 Prefix
=> Prefix
(N
),
4258 Attribute_Name
=> Name_Object_Size
));
4260 Analyze_And_Resolve
(N
, Typ
);
4266 -- The only case that can get this far is the dynamic case of the old
4267 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4274 -- ityp (System.Mantissa.Mantissa_Value
4275 -- (Integer'Integer_Value (typ'First),
4276 -- Integer'Integer_Value (typ'Last)));
4278 when Attribute_Mantissa
=>
4281 Make_Function_Call
(Loc
,
4283 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4285 Parameter_Associations
=> New_List
(
4286 Make_Attribute_Reference
(Loc
,
4287 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4288 Attribute_Name
=> Name_Integer_Value
,
4289 Expressions
=> New_List
(
4290 Make_Attribute_Reference
(Loc
,
4291 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4292 Attribute_Name
=> Name_First
))),
4294 Make_Attribute_Reference
(Loc
,
4295 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4296 Attribute_Name
=> Name_Integer_Value
,
4297 Expressions
=> New_List
(
4298 Make_Attribute_Reference
(Loc
,
4299 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4300 Attribute_Name
=> Name_Last
)))))));
4302 Analyze_And_Resolve
(N
, Typ
);
4308 when Attribute_Max
=>
4309 Expand_Min_Max_Attribute
(N
);
4311 ----------------------------------
4312 -- Max_Size_In_Storage_Elements --
4313 ----------------------------------
4315 when Attribute_Max_Size_In_Storage_Elements
=> declare
4316 Typ
: constant Entity_Id
:= Etype
(N
);
4319 Conversion_Added
: Boolean := False;
4320 -- A flag which tracks whether the original attribute has been
4321 -- wrapped inside a type conversion.
4324 -- If the prefix is X'Class, we transform it into a direct reference
4325 -- to the class-wide type, because the back end must not see a 'Class
4326 -- reference. See also 'Size.
4328 if Is_Entity_Name
(Pref
)
4329 and then Is_Class_Wide_Type
(Entity
(Pref
))
4331 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4335 Apply_Universal_Integer_Attribute_Checks
(N
);
4337 -- The universal integer check may sometimes add a type conversion,
4338 -- retrieve the original attribute reference from the expression.
4342 if Nkind
(Attr
) = N_Type_Conversion
then
4343 Attr
:= Expression
(Attr
);
4344 Conversion_Added
:= True;
4347 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
4349 -- Heap-allocated controlled objects contain two extra pointers which
4350 -- are not part of the actual type. Transform the attribute reference
4351 -- into a runtime expression to add the size of the hidden header.
4353 if Needs_Finalization
(Ptyp
)
4354 and then not Header_Size_Added
(Attr
)
4356 Set_Header_Size_Added
(Attr
);
4359 -- P'Max_Size_In_Storage_Elements +
4360 -- Universal_Integer
4361 -- (Header_Size_With_Padding (Ptyp'Alignment))
4365 Left_Opnd
=> Relocate_Node
(Attr
),
4367 Convert_To
(Universal_Integer
,
4368 Make_Function_Call
(Loc
,
4371 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4373 Parameter_Associations
=> New_List
(
4374 Make_Attribute_Reference
(Loc
,
4376 New_Occurrence_Of
(Ptyp
, Loc
),
4377 Attribute_Name
=> Name_Alignment
))))));
4379 -- Add a conversion to the target type
4381 if not Conversion_Added
then
4383 Make_Type_Conversion
(Loc
,
4384 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4385 Expression
=> Relocate_Node
(Attr
)));
4393 --------------------
4394 -- Mechanism_Code --
4395 --------------------
4397 when Attribute_Mechanism_Code
=>
4399 -- We must replace the prefix in the renamed case
4401 if Is_Entity_Name
(Pref
)
4402 and then Present
(Alias
(Entity
(Pref
)))
4404 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4411 when Attribute_Min
=>
4412 Expand_Min_Max_Attribute
(N
);
4418 when Attribute_Mod
=> Mod_Case
: declare
4419 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4420 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
4421 Modv
: constant Uint
:= Modulus
(Btyp
);
4425 -- This is not so simple. The issue is what type to use for the
4426 -- computation of the modular value.
4428 -- The easy case is when the modulus value is within the bounds
4429 -- of the signed integer type of the argument. In this case we can
4430 -- just do the computation in that signed integer type, and then
4431 -- do an ordinary conversion to the target type.
4433 if Modv
<= Expr_Value
(Hi
) then
4438 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4440 -- Here we know that the modulus is larger than type'Last of the
4441 -- integer type. There are two cases to consider:
4443 -- a) The integer value is non-negative. In this case, it is
4444 -- returned as the result (since it is less than the modulus).
4446 -- b) The integer value is negative. In this case, we know that the
4447 -- result is modulus + value, where the value might be as small as
4448 -- -modulus. The trouble is what type do we use to do the subtract.
4449 -- No type will do, since modulus can be as big as 2**64, and no
4450 -- integer type accommodates this value. Let's do bit of algebra
4453 -- = modulus - (-value)
4454 -- = (modulus - 1) - (-value - 1)
4456 -- Now modulus - 1 is certainly in range of the modular type.
4457 -- -value is in the range 1 .. modulus, so -value -1 is in the
4458 -- range 0 .. modulus-1 which is in range of the modular type.
4459 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4460 -- which we can compute using the integer base type.
4462 -- Once this is done we analyze the if expression without range
4463 -- checks, because we know everything is in range, and we want
4464 -- to prevent spurious warnings on either branch.
4468 Make_If_Expression
(Loc
,
4469 Expressions
=> New_List
(
4471 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4472 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4475 Duplicate_Subexpr_No_Checks
(Arg
)),
4477 Make_Op_Subtract
(Loc
,
4479 Make_Integer_Literal
(Loc
,
4480 Intval
=> Modv
- 1),
4486 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4488 Make_Integer_Literal
(Loc
,
4489 Intval
=> 1))))))));
4493 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4500 -- Transforms 'Model into a call to the floating-point attribute
4501 -- function Model in Fat_xxx (where xxx is the root type).
4502 -- Expansion is avoided for cases the back end can handle directly.
4504 when Attribute_Model
=>
4505 if not Is_Inline_Floating_Point_Attribute
(N
) then
4506 Expand_Fpt_Attribute_R
(N
);
4513 -- The processing for Object_Size shares the processing for Size
4519 when Attribute_Old
=> Old
: declare
4520 Typ
: constant Entity_Id
:= Etype
(N
);
4521 CW_Temp
: Entity_Id
;
4528 -- Generating C code we don't need to expand this attribute when
4529 -- we are analyzing the internally built nested postconditions
4530 -- procedure since it will be expanded inline (and later it will
4531 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4532 -- performed in such case then the compiler generates unreferenced
4533 -- extra temporaries.
4535 if Modify_Tree_For_C
4536 and then Chars
(Current_Scope
) = Name_uPostconditions
4541 -- Climb the parent chain looking for subprogram _Postconditions
4544 while Present
(Subp
) loop
4545 exit when Nkind
(Subp
) = N_Subprogram_Body
4546 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4548 -- If assertions are disabled, no need to create the declaration
4549 -- that preserves the value. The postcondition pragma in which
4550 -- 'Old appears will be checked or disabled according to the
4551 -- current policy in effect.
4553 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4557 Subp
:= Parent
(Subp
);
4560 -- 'Old can only appear in a postcondition, the generated body of
4561 -- _Postconditions must be in the tree (or inlined if we are
4562 -- generating C code).
4566 or else (Modify_Tree_For_C
and then In_Inlined_Body
));
4568 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4570 -- Set the entity kind now in order to mark the temporary as a
4571 -- handler of attribute 'Old's prefix.
4573 Set_Ekind
(Temp
, E_Constant
);
4574 Set_Stores_Attribute_Old_Prefix
(Temp
);
4576 -- Push the scope of the related subprogram where _Postcondition
4577 -- resides as this ensures that the object will be analyzed in the
4580 if Present
(Subp
) then
4581 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4583 -- No need to push the scope when generating C code since the
4584 -- _Postcondition procedure has been inlined.
4586 else pragma Assert
(Modify_Tree_For_C
);
4587 pragma Assert
(In_Inlined_Body
);
4591 -- Locate the insertion place of the internal temporary that saves
4594 if Present
(Subp
) then
4597 -- Generating C, the postcondition procedure has been inlined and the
4598 -- temporary is added before the first declaration of the enclosing
4601 else pragma Assert
(Modify_Tree_For_C
);
4603 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
4604 Ins_Nod
:= Parent
(Ins_Nod
);
4607 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
4610 -- Preserve the tag of the prefix by offering a specific view of the
4611 -- class-wide version of the prefix.
4613 if Is_Tagged_Type
(Typ
) then
4616 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4618 CW_Temp
:= Make_Temporary
(Loc
, 'T');
4619 CW_Typ
:= Class_Wide_Type
(Typ
);
4621 Insert_Before_And_Analyze
(Ins_Nod
,
4622 Make_Object_Declaration
(Loc
,
4623 Defining_Identifier
=> CW_Temp
,
4624 Constant_Present
=> True,
4625 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
4627 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
4630 -- Temp : Typ renames Typ (CW_Temp);
4632 Insert_Before_And_Analyze
(Ins_Nod
,
4633 Make_Object_Renaming_Declaration
(Loc
,
4634 Defining_Identifier
=> Temp
,
4635 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4637 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
4643 -- Temp : constant Typ := Pref;
4645 Insert_Before_And_Analyze
(Ins_Nod
,
4646 Make_Object_Declaration
(Loc
,
4647 Defining_Identifier
=> Temp
,
4648 Constant_Present
=> True,
4649 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
4650 Expression
=> Relocate_Node
(Pref
)));
4653 if Present
(Subp
) then
4657 -- Ensure that the prefix of attribute 'Old is valid. The check must
4658 -- be inserted after the expansion of the attribute has taken place
4659 -- to reflect the new placement of the prefix.
4661 if Validity_Checks_On
and then Validity_Check_Operands
then
4662 Ensure_Valid
(Pref
);
4665 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4668 ----------------------
4669 -- Overlaps_Storage --
4670 ----------------------
4672 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4673 Loc
: constant Source_Ptr
:= Sloc
(N
);
4675 X
: constant Node_Id
:= Prefix
(N
);
4676 Y
: constant Node_Id
:= First
(Expressions
(N
));
4679 X_Addr
, Y_Addr
: Node_Id
;
4680 -- the expressions for their integer addresses
4682 X_Size
, Y_Size
: Node_Id
;
4683 -- the expressions for their sizes
4688 -- Attribute expands into:
4690 -- if X'Address < Y'address then
4691 -- (X'address + X'Size - 1) >= Y'address
4693 -- (Y'address + Y'size - 1) >= X'Address
4696 -- with the proper address operations. We convert addresses to
4697 -- integer addresses to use predefined arithmetic. The size is
4698 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4699 -- to prevent the appearance of the same node in two places in
4703 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4704 Make_Attribute_Reference
(Loc
,
4705 Attribute_Name
=> Name_Address
,
4706 Prefix
=> New_Copy_Tree
(X
)));
4709 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4710 Make_Attribute_Reference
(Loc
,
4711 Attribute_Name
=> Name_Address
,
4712 Prefix
=> New_Copy_Tree
(Y
)));
4715 Make_Op_Divide
(Loc
,
4717 Make_Attribute_Reference
(Loc
,
4718 Attribute_Name
=> Name_Size
,
4719 Prefix
=> New_Copy_Tree
(X
)),
4721 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4724 Make_Op_Divide
(Loc
,
4726 Make_Attribute_Reference
(Loc
,
4727 Attribute_Name
=> Name_Size
,
4728 Prefix
=> New_Copy_Tree
(Y
)),
4730 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4734 Left_Opnd
=> X_Addr
,
4735 Right_Opnd
=> Y_Addr
);
4738 Make_If_Expression
(Loc
, New_List
(
4744 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
4746 Make_Op_Subtract
(Loc
,
4747 Left_Opnd
=> X_Size
,
4748 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4749 Right_Opnd
=> Y_Addr
),
4754 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
4756 Make_Op_Subtract
(Loc
,
4757 Left_Opnd
=> Y_Size
,
4758 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4759 Right_Opnd
=> X_Addr
))));
4761 Analyze_And_Resolve
(N
, Standard_Boolean
);
4762 end Overlaps_Storage
;
4768 when Attribute_Output
=> Output
: declare
4769 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4770 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4778 -- If no underlying type, we have an error that will be diagnosed
4779 -- elsewhere, so here we just completely ignore the expansion.
4785 -- Stream operations can appear in user code even if the restriction
4786 -- No_Streams is active (for example, when instantiating a predefined
4787 -- container). In that case rewrite the attribute as a Raise to
4788 -- prevent any run-time use.
4790 if Restriction_Active
(No_Streams
) then
4792 Make_Raise_Program_Error
(Sloc
(N
),
4793 Reason
=> PE_Stream_Operation_Not_Allowed
));
4794 Set_Etype
(N
, Standard_Void_Type
);
4798 -- If TSS for Output is present, just call it
4800 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
4802 if Present
(Pname
) then
4806 -- If there is a Stream_Convert pragma, use it, we rewrite
4808 -- sourcetyp'Output (stream, Item)
4812 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4814 -- where strmwrite is the given Write function that converts an
4815 -- argument of type sourcetyp or a type acctyp, from which it is
4816 -- derived to type strmtyp. The conversion to acttyp is required
4817 -- for the derived case.
4819 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4821 if Present
(Prag
) then
4823 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4824 Wfunc
:= Entity
(Expression
(Arg3
));
4827 Make_Attribute_Reference
(Loc
,
4828 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4829 Attribute_Name
=> Name_Output
,
4830 Expressions
=> New_List
(
4831 Relocate_Node
(First
(Exprs
)),
4832 Make_Function_Call
(Loc
,
4833 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4834 Parameter_Associations
=> New_List
(
4835 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4836 Relocate_Node
(Next
(First
(Exprs
)))))))));
4841 -- For elementary types, we call the W_xxx routine directly. Note
4842 -- that the effect of Write and Output is identical for the case
4843 -- of an elementary type (there are no discriminants or bounds).
4845 elsif Is_Elementary_Type
(U_Type
) then
4847 -- A special case arises if we have a defined _Write routine,
4848 -- since in this case we are required to call this routine.
4851 Typ
: Entity_Id
:= P_Type
;
4853 if Present
(Full_View
(Typ
)) then
4854 Typ
:= Full_View
(Typ
);
4857 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Write
)) then
4858 Build_Record_Or_Elementary_Output_Procedure
4859 (Loc
, Typ
, Decl
, Pname
);
4860 Insert_Action
(N
, Decl
);
4862 -- For normal cases, we call the W_xxx routine directly
4865 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4873 elsif Is_Array_Type
(U_Type
) then
4874 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4875 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4877 -- Class-wide case, first output external tag, then dispatch
4878 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4880 elsif Is_Class_Wide_Type
(P_Type
) then
4882 -- No need to do anything else compiling under restriction
4883 -- No_Dispatching_Calls. During the semantic analysis we
4884 -- already notified such violation.
4886 if Restriction_Active
(No_Dispatching_Calls
) then
4891 Strm
: constant Node_Id
:= First
(Exprs
);
4892 Item
: constant Node_Id
:= Next
(Strm
);
4895 -- Ada 2005 (AI-344): Check that the accessibility level
4896 -- of the type of the output object is not deeper than
4897 -- that of the attribute's prefix type.
4899 -- if Get_Access_Level (Item'Tag)
4900 -- /= Get_Access_Level (P_Type'Tag)
4905 -- String'Output (Strm, External_Tag (Item'Tag));
4907 -- We cannot figure out a practical way to implement this
4908 -- accessibility check on virtual machines, so we omit it.
4910 if Ada_Version
>= Ada_2005
4911 and then Tagged_Type_Expansion
4914 Make_Implicit_If_Statement
(N
,
4918 Build_Get_Access_Level
(Loc
,
4919 Make_Attribute_Reference
(Loc
,
4922 Duplicate_Subexpr
(Item
,
4924 Attribute_Name
=> Name_Tag
)),
4927 Make_Integer_Literal
(Loc
,
4928 Type_Access_Level
(P_Type
))),
4931 New_List
(Make_Raise_Statement
(Loc
,
4933 RTE
(RE_Tag_Error
), Loc
)))));
4937 Make_Attribute_Reference
(Loc
,
4938 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
4939 Attribute_Name
=> Name_Output
,
4940 Expressions
=> New_List
(
4941 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
4942 Make_Function_Call
(Loc
,
4944 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
4945 Parameter_Associations
=> New_List
(
4946 Make_Attribute_Reference
(Loc
,
4949 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
4950 Attribute_Name
=> Name_Tag
))))));
4953 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4955 -- Tagged type case, use the primitive Output function
4957 elsif Is_Tagged_Type
(U_Type
) then
4958 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4960 -- All other record type cases, including protected records.
4961 -- The latter only arise for expander generated code for
4962 -- handling shared passive partition access.
4966 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4968 -- Ada 2005 (AI-216): Program_Error is raised when executing
4969 -- the default implementation of the Output attribute of an
4970 -- unchecked union type if the type lacks default discriminant
4973 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4974 and then No
(Discriminant_Constraint
(U_Type
))
4977 Make_Raise_Program_Error
(Loc
,
4978 Reason
=> PE_Unchecked_Union_Restriction
));
4983 Build_Record_Or_Elementary_Output_Procedure
4984 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
4985 Insert_Action
(N
, Decl
);
4989 -- If we fall through, Pname is the name of the procedure to call
4991 Rewrite_Stream_Proc_Call
(Pname
);
4998 -- For enumeration types with a standard representation, Pos is
4999 -- handled by the back end.
5001 -- For enumeration types, with a non-standard representation we generate
5002 -- a call to the _Rep_To_Pos function created when the type was frozen.
5003 -- The call has the form
5005 -- _rep_to_pos (expr, flag)
5007 -- The parameter flag is True if range checks are enabled, causing
5008 -- Program_Error to be raised if the expression has an invalid
5009 -- representation, and False if range checks are suppressed.
5011 -- For integer types, Pos is equivalent to a simple integer
5012 -- conversion and we rewrite it as such
5014 when Attribute_Pos
=> Pos
: declare
5015 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
5018 -- Deal with zero/non-zero boolean values
5020 if Is_Boolean_Type
(Etyp
) then
5021 Adjust_Condition
(First
(Exprs
));
5022 Etyp
:= Standard_Boolean
;
5023 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5026 -- Case of enumeration type
5028 if Is_Enumeration_Type
(Etyp
) then
5030 -- Non-standard enumeration type (generate call)
5032 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5033 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5036 Make_Function_Call
(Loc
,
5038 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5039 Parameter_Associations
=> Exprs
)));
5041 Analyze_And_Resolve
(N
, Typ
);
5043 -- Standard enumeration type (do universal integer check)
5046 Apply_Universal_Integer_Attribute_Checks
(N
);
5049 -- Deal with integer types (replace by conversion)
5051 elsif Is_Integer_Type
(Etyp
) then
5052 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
5053 Analyze_And_Resolve
(N
, Typ
);
5062 -- We compute this if a component clause was present, otherwise we leave
5063 -- the computation up to the back end, since we don't know what layout
5066 when Attribute_Position
=> Position_Attr
: declare
5067 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5070 if Present
(Component_Clause
(CE
)) then
5072 -- In Ada 2005 (or later) if we have the non-default bit order,
5073 -- then we return the original value as given in the component
5074 -- clause (RM 2005 13.5.2(2/2)).
5076 if Ada_Version
>= Ada_2005
5077 and then Reverse_Bit_Order
(Scope
(CE
))
5080 Make_Integer_Literal
(Loc
,
5081 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
5083 -- Otherwise (Ada 83 or 95, or default bit order specified in
5084 -- later Ada version), return the normalized value.
5088 Make_Integer_Literal
(Loc
,
5089 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
5092 Analyze_And_Resolve
(N
, Typ
);
5094 -- If back end is doing things, just apply universal integer checks
5097 Apply_Universal_Integer_Attribute_Checks
(N
);
5105 -- 1. Deal with enumeration types with holes.
5106 -- 2. For floating-point, generate call to attribute function.
5107 -- 3. For other cases, deal with constraint checking.
5109 when Attribute_Pred
=> Pred
: declare
5110 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5114 -- For enumeration types with non-standard representations, we
5115 -- expand typ'Pred (x) into
5117 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5119 -- If the representation is contiguous, we compute instead
5120 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5121 -- The conversion function Enum_Pos_To_Rep is defined on the
5122 -- base type, not the subtype, so we have to use the base type
5123 -- explicitly for this and other enumeration attributes.
5125 if Is_Enumeration_Type
(Ptyp
)
5126 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5128 if Has_Contiguous_Rep
(Etyp
) then
5130 Unchecked_Convert_To
(Ptyp
,
5133 Make_Integer_Literal
(Loc
,
5134 Enumeration_Rep
(First_Literal
(Ptyp
))),
5136 Make_Function_Call
(Loc
,
5139 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5141 Parameter_Associations
=>
5143 Unchecked_Convert_To
(Ptyp
,
5144 Make_Op_Subtract
(Loc
,
5146 Unchecked_Convert_To
(Standard_Integer
,
5147 Relocate_Node
(First
(Exprs
))),
5149 Make_Integer_Literal
(Loc
, 1))),
5150 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5153 -- Add Boolean parameter True, to request program errror if
5154 -- we have a bad representation on our hands. If checks are
5155 -- suppressed, then add False instead
5157 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5159 Make_Indexed_Component
(Loc
,
5162 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5163 Expressions
=> New_List
(
5164 Make_Op_Subtract
(Loc
,
5166 Make_Function_Call
(Loc
,
5169 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5170 Parameter_Associations
=> Exprs
),
5171 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5174 Analyze_And_Resolve
(N
, Typ
);
5176 -- For floating-point, we transform 'Pred into a call to the Pred
5177 -- floating-point attribute function in Fat_xxx (xxx is root type).
5178 -- Note that this function takes care of the overflow case.
5180 elsif Is_Floating_Point_Type
(Ptyp
) then
5181 Expand_Fpt_Attribute_R
(N
);
5182 Analyze_And_Resolve
(N
, Typ
);
5184 -- For modular types, nothing to do (no overflow, since wraps)
5186 elsif Is_Modular_Integer_Type
(Ptyp
) then
5189 -- For other types, if argument is marked as needing a range check or
5190 -- overflow checking is enabled, we must generate a check.
5192 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5193 or else Do_Range_Check
(First
(Exprs
))
5195 Set_Do_Range_Check
(First
(Exprs
), False);
5196 Expand_Pred_Succ_Attribute
(N
);
5204 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5206 -- We rewrite X'Priority as the following run-time call:
5208 -- Get_Ceiling (X._Object)
5210 -- Note that although X'Priority is notionally an object, it is quite
5211 -- deliberately not defined as an aliased object in the RM. This means
5212 -- that it works fine to rewrite it as a call, without having to worry
5213 -- about complications that would other arise from X'Priority'Access,
5214 -- which is illegal, because of the lack of aliasing.
5216 when Attribute_Priority
=> Priority
: declare
5218 Conctyp
: Entity_Id
;
5219 New_Itype
: Entity_Id
;
5220 Object_Parm
: Node_Id
;
5222 RT_Subprg_Name
: Node_Id
;
5225 -- Look for the enclosing concurrent type
5227 Conctyp
:= Current_Scope
;
5228 while not Is_Concurrent_Type
(Conctyp
) loop
5229 Conctyp
:= Scope
(Conctyp
);
5232 pragma Assert
(Is_Protected_Type
(Conctyp
));
5234 -- Generate the actual of the call
5236 Subprg
:= Current_Scope
;
5237 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5238 Subprg
:= Scope
(Subprg
);
5241 -- Use of 'Priority inside protected entries and barriers (in both
5242 -- cases the type of the first formal of their expanded subprogram
5245 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5248 -- In the expansion of protected entries the type of the first
5249 -- formal of the Protected_Body_Subprogram is an Address. In order
5250 -- to reference the _object component we generate:
5252 -- type T is access p__ptTV;
5255 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5256 Set_Etype
(New_Itype
, New_Itype
);
5257 Set_Directly_Designated_Type
(New_Itype
,
5258 Corresponding_Record_Type
(Conctyp
));
5259 Freeze_Itype
(New_Itype
, N
);
5262 -- T!(O)._object'unchecked_access
5265 Make_Attribute_Reference
(Loc
,
5267 Make_Selected_Component
(Loc
,
5269 Unchecked_Convert_To
(New_Itype
,
5271 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5273 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5274 Attribute_Name
=> Name_Unchecked_Access
);
5276 -- Use of 'Priority inside a protected subprogram
5280 Make_Attribute_Reference
(Loc
,
5282 Make_Selected_Component
(Loc
,
5285 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5287 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5288 Attribute_Name
=> Name_Unchecked_Access
);
5291 -- Select the appropriate run-time subprogram
5293 if Number_Entries
(Conctyp
) = 0 then
5294 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5296 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5300 Make_Function_Call
(Loc
,
5301 Name
=> RT_Subprg_Name
,
5302 Parameter_Associations
=> New_List
(Object_Parm
));
5306 -- Avoid the generation of extra checks on the pointer to the
5307 -- protected object.
5309 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5316 when Attribute_Range_Length
=>
5318 -- The only special processing required is for the case where
5319 -- Range_Length is applied to an enumeration type with holes.
5320 -- In this case we transform
5326 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5328 -- So that the result reflects the proper Pos values instead
5329 -- of the underlying representations.
5331 if Is_Enumeration_Type
(Ptyp
)
5332 and then Has_Non_Standard_Rep
(Ptyp
)
5337 Make_Op_Subtract
(Loc
,
5339 Make_Attribute_Reference
(Loc
,
5340 Attribute_Name
=> Name_Pos
,
5341 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5342 Expressions
=> New_List
(
5343 Make_Attribute_Reference
(Loc
,
5344 Attribute_Name
=> Name_Last
,
5346 New_Occurrence_Of
(Ptyp
, Loc
)))),
5349 Make_Attribute_Reference
(Loc
,
5350 Attribute_Name
=> Name_Pos
,
5351 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5352 Expressions
=> New_List
(
5353 Make_Attribute_Reference
(Loc
,
5354 Attribute_Name
=> Name_First
,
5356 New_Occurrence_Of
(Ptyp
, Loc
))))),
5358 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5360 Analyze_And_Resolve
(N
, Typ
);
5362 -- For all other cases, the attribute is handled by the back end, but
5363 -- we need to deal with the case of the range check on a universal
5367 Apply_Universal_Integer_Attribute_Checks
(N
);
5374 when Attribute_Read
=> Read
: declare
5375 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5376 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
5377 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5387 -- If no underlying type, we have an error that will be diagnosed
5388 -- elsewhere, so here we just completely ignore the expansion.
5394 -- Stream operations can appear in user code even if the restriction
5395 -- No_Streams is active (for example, when instantiating a predefined
5396 -- container). In that case rewrite the attribute as a Raise to
5397 -- prevent any run-time use.
5399 if Restriction_Active
(No_Streams
) then
5401 Make_Raise_Program_Error
(Sloc
(N
),
5402 Reason
=> PE_Stream_Operation_Not_Allowed
));
5403 Set_Etype
(N
, B_Type
);
5407 -- The simple case, if there is a TSS for Read, just call it
5409 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
5411 if Present
(Pname
) then
5415 -- If there is a Stream_Convert pragma, use it, we rewrite
5417 -- sourcetyp'Read (stream, Item)
5421 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5423 -- where strmread is the given Read function that converts an
5424 -- argument of type strmtyp to type sourcetyp or a type from which
5425 -- it is derived. The conversion to sourcetyp is required in the
5428 -- A special case arises if Item is a type conversion in which
5429 -- case, we have to expand to:
5431 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5433 -- where Itemx is the expression of the type conversion (i.e.
5434 -- the actual object), and typex is the type of Itemx.
5436 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5438 if Present
(Prag
) then
5439 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
5440 Rfunc
:= Entity
(Expression
(Arg2
));
5441 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5443 OK_Convert_To
(B_Type
,
5444 Make_Function_Call
(Loc
,
5445 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
5446 Parameter_Associations
=> New_List
(
5447 Make_Attribute_Reference
(Loc
,
5450 (Etype
(First_Formal
(Rfunc
)), Loc
),
5451 Attribute_Name
=> Name_Input
,
5452 Expressions
=> New_List
(
5453 Relocate_Node
(First
(Exprs
)))))));
5455 if Nkind
(Lhs
) = N_Type_Conversion
then
5456 Lhs
:= Expression
(Lhs
);
5457 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5461 Make_Assignment_Statement
(Loc
,
5463 Expression
=> Rhs
));
5464 Set_Assignment_OK
(Lhs
);
5468 -- For elementary types, we call the I_xxx routine using the first
5469 -- parameter and then assign the result into the second parameter.
5470 -- We set Assignment_OK to deal with the conversion case.
5472 elsif Is_Elementary_Type
(U_Type
) then
5478 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5479 Rhs
:= Build_Elementary_Input_Call
(N
);
5481 if Nkind
(Lhs
) = N_Type_Conversion
then
5482 Lhs
:= Expression
(Lhs
);
5483 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5486 Set_Assignment_OK
(Lhs
);
5489 Make_Assignment_Statement
(Loc
,
5491 Expression
=> Rhs
));
5499 elsif Is_Array_Type
(U_Type
) then
5500 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
5501 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5503 -- Tagged type case, use the primitive Read function. Note that
5504 -- this will dispatch in the class-wide case which is what we want
5506 elsif Is_Tagged_Type
(U_Type
) then
5507 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
5509 -- All other record type cases, including protected records. The
5510 -- latter only arise for expander generated code for handling
5511 -- shared passive partition access.
5515 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5517 -- Ada 2005 (AI-216): Program_Error is raised when executing
5518 -- the default implementation of the Read attribute of an
5519 -- Unchecked_Union type.
5521 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
5523 Make_Raise_Program_Error
(Loc
,
5524 Reason
=> PE_Unchecked_Union_Restriction
));
5527 if Has_Discriminants
(U_Type
)
5529 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5531 Build_Mutable_Record_Read_Procedure
5532 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5534 Build_Record_Read_Procedure
5535 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5538 -- Suppress checks, uninitialized or otherwise invalid
5539 -- data does not cause constraint errors to be raised for
5540 -- a complete record read.
5542 Insert_Action
(N
, Decl
, All_Checks
);
5546 Rewrite_Stream_Proc_Call
(Pname
);
5553 -- Ref is identical to To_Address, see To_Address for processing
5559 -- Transforms 'Remainder into a call to the floating-point attribute
5560 -- function Remainder in Fat_xxx (where xxx is the root type)
5562 when Attribute_Remainder
=>
5563 Expand_Fpt_Attribute_RR
(N
);
5569 -- Transform 'Result into reference to _Result formal. At the point
5570 -- where a legal 'Result attribute is expanded, we know that we are in
5571 -- the context of a _Postcondition function with a _Result parameter.
5573 when Attribute_Result
=>
5574 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
5575 Analyze_And_Resolve
(N
, Typ
);
5581 -- The handling of the Round attribute is quite delicate. The processing
5582 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5583 -- semantics of Round, but we do not want anything to do with universal
5584 -- real at runtime, since this corresponds to using floating-point
5587 -- What we have now is that the Etype of the Round attribute correctly
5588 -- indicates the final result type. The operand of the Round is the
5589 -- conversion to universal real, described above, and the operand of
5590 -- this conversion is the actual operand of Round, which may be the
5591 -- special case of a fixed point multiplication or division (Etype =
5594 -- The exapander will expand first the operand of the conversion, then
5595 -- the conversion, and finally the round attribute itself, since we
5596 -- always work inside out. But we cannot simply process naively in this
5597 -- order. In the semantic world where universal fixed and real really
5598 -- exist and have infinite precision, there is no problem, but in the
5599 -- implementation world, where universal real is a floating-point type,
5600 -- we would get the wrong result.
5602 -- So the approach is as follows. First, when expanding a multiply or
5603 -- divide whose type is universal fixed, we do nothing at all, instead
5604 -- deferring the operation till later.
5606 -- The actual processing is done in Expand_N_Type_Conversion which
5607 -- handles the special case of Round by looking at its parent to see if
5608 -- it is a Round attribute, and if it is, handling the conversion (or
5609 -- its fixed multiply/divide child) in an appropriate manner.
5611 -- This means that by the time we get to expanding the Round attribute
5612 -- itself, the Round is nothing more than a type conversion (and will
5613 -- often be a null type conversion), so we just replace it with the
5614 -- appropriate conversion operation.
5616 when Attribute_Round
=>
5618 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
5619 Analyze_And_Resolve
(N
);
5625 -- Transforms 'Rounding into a call to the floating-point attribute
5626 -- function Rounding in Fat_xxx (where xxx is the root type)
5627 -- Expansion is avoided for cases the back end can handle directly.
5629 when Attribute_Rounding
=>
5630 if not Is_Inline_Floating_Point_Attribute
(N
) then
5631 Expand_Fpt_Attribute_R
(N
);
5638 -- Transforms 'Scaling into a call to the floating-point attribute
5639 -- function Scaling in Fat_xxx (where xxx is the root type)
5641 when Attribute_Scaling
=>
5642 Expand_Fpt_Attribute_RI
(N
);
5644 -------------------------
5645 -- Simple_Storage_Pool --
5646 -------------------------
5648 when Attribute_Simple_Storage_Pool
=>
5650 Make_Type_Conversion
(Loc
,
5651 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5652 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5653 Analyze_And_Resolve
(N
, Typ
);
5659 when Attribute_Object_Size
5661 | Attribute_Value_Size
5662 | Attribute_VADS_Size
5669 -- Processing for VADS_Size case. Note that this processing
5670 -- removes all traces of VADS_Size from the tree, and completes
5671 -- all required processing for VADS_Size by translating the
5672 -- attribute reference to an appropriate Size or Object_Size
5675 if Id
= Attribute_VADS_Size
5676 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5678 -- If the size is specified, then we simply use the specified
5679 -- size. This applies to both types and objects. The size of an
5680 -- object can be specified in the following ways:
5682 -- An explicit size object is given for an object
5683 -- A component size is specified for an indexed component
5684 -- A component clause is specified for a selected component
5685 -- The object is a component of a packed composite object
5687 -- If the size is specified, then VADS_Size of an object
5689 if (Is_Entity_Name
(Pref
)
5690 and then Present
(Size_Clause
(Entity
(Pref
))))
5692 (Nkind
(Pref
) = N_Component_Clause
5693 and then (Present
(Component_Clause
5694 (Entity
(Selector_Name
(Pref
))))
5695 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5697 (Nkind
(Pref
) = N_Indexed_Component
5698 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5699 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5701 Set_Attribute_Name
(N
, Name_Size
);
5703 -- Otherwise if we have an object rather than a type, then
5704 -- the VADS_Size attribute applies to the type of the object,
5705 -- rather than the object itself. This is one of the respects
5706 -- in which VADS_Size differs from Size.
5709 if (not Is_Entity_Name
(Pref
)
5710 or else not Is_Type
(Entity
(Pref
)))
5711 and then (Is_Scalar_Type
(Ptyp
)
5712 or else Is_Constrained
(Ptyp
))
5714 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
5717 -- For a scalar type for which no size was explicitly given,
5718 -- VADS_Size means Object_Size. This is the other respect in
5719 -- which VADS_Size differs from Size.
5721 if Is_Scalar_Type
(Ptyp
)
5722 and then No
(Size_Clause
(Ptyp
))
5724 Set_Attribute_Name
(N
, Name_Object_Size
);
5726 -- In all other cases, Size and VADS_Size are the sane
5729 Set_Attribute_Name
(N
, Name_Size
);
5734 -- If the prefix is X'Class, transform it into a direct reference
5735 -- to the class-wide type, because the back end must not see a
5736 -- 'Class reference.
5738 if Is_Entity_Name
(Pref
)
5739 and then Is_Class_Wide_Type
(Entity
(Pref
))
5741 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
5744 -- For X'Size applied to an object of a class-wide type, transform
5745 -- X'Size into a call to the primitive operation _Size applied to
5748 elsif Is_Class_Wide_Type
(Ptyp
) then
5750 -- No need to do anything else compiling under restriction
5751 -- No_Dispatching_Calls. During the semantic analysis we
5752 -- already noted this restriction violation.
5754 if Restriction_Active
(No_Dispatching_Calls
) then
5759 Make_Function_Call
(Loc
,
5761 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
5762 Parameter_Associations
=> New_List
(Pref
));
5764 if Typ
/= Standard_Long_Long_Integer
then
5766 -- The context is a specific integer type with which the
5767 -- original attribute was compatible. The function has a
5768 -- specific type as well, so to preserve the compatibility
5769 -- we must convert explicitly.
5771 New_Node
:= Convert_To
(Typ
, New_Node
);
5774 Rewrite
(N
, New_Node
);
5775 Analyze_And_Resolve
(N
, Typ
);
5778 -- Case of known RM_Size of a type
5780 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
5781 and then Is_Entity_Name
(Pref
)
5782 and then Is_Type
(Entity
(Pref
))
5783 and then Known_Static_RM_Size
(Entity
(Pref
))
5785 Siz
:= RM_Size
(Entity
(Pref
));
5787 -- Case of known Esize of a type
5789 elsif Id
= Attribute_Object_Size
5790 and then Is_Entity_Name
(Pref
)
5791 and then Is_Type
(Entity
(Pref
))
5792 and then Known_Static_Esize
(Entity
(Pref
))
5794 Siz
:= Esize
(Entity
(Pref
));
5796 -- Case of known size of object
5798 elsif Id
= Attribute_Size
5799 and then Is_Entity_Name
(Pref
)
5800 and then Is_Object
(Entity
(Pref
))
5801 and then Known_Esize
(Entity
(Pref
))
5802 and then Known_Static_Esize
(Entity
(Pref
))
5804 Siz
:= Esize
(Entity
(Pref
));
5806 -- For an array component, we can do Size in the front end if the
5807 -- component_size of the array is set.
5809 elsif Nkind
(Pref
) = N_Indexed_Component
then
5810 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
5812 -- For a record component, we can do Size in the front end if
5813 -- there is a component clause, or if the record is packed and the
5814 -- component's size is known at compile time.
5816 elsif Nkind
(Pref
) = N_Selected_Component
then
5818 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
5819 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5822 if Present
(Component_Clause
(Comp
)) then
5823 Siz
:= Esize
(Comp
);
5825 elsif Is_Packed
(Rec
) then
5826 Siz
:= RM_Size
(Ptyp
);
5829 Apply_Universal_Integer_Attribute_Checks
(N
);
5834 -- All other cases are handled by the back end
5837 Apply_Universal_Integer_Attribute_Checks
(N
);
5839 -- If Size is applied to a formal parameter that is of a packed
5840 -- array subtype, then apply Size to the actual subtype.
5842 if Is_Entity_Name
(Pref
)
5843 and then Is_Formal
(Entity
(Pref
))
5844 and then Is_Array_Type
(Ptyp
)
5845 and then Is_Packed
(Ptyp
)
5848 Make_Attribute_Reference
(Loc
,
5850 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
5851 Attribute_Name
=> Name_Size
));
5852 Analyze_And_Resolve
(N
, Typ
);
5855 -- If Size applies to a dereference of an access to
5856 -- unconstrained packed array, the back end needs to see its
5857 -- unconstrained nominal type, but also a hint to the actual
5858 -- constrained type.
5860 if Nkind
(Pref
) = N_Explicit_Dereference
5861 and then Is_Array_Type
(Ptyp
)
5862 and then not Is_Constrained
(Ptyp
)
5863 and then Is_Packed
(Ptyp
)
5865 Set_Actual_Designated_Subtype
(Pref
,
5866 Get_Actual_Subtype
(Pref
));
5872 -- Common processing for record and array component case
5874 if Siz
/= No_Uint
and then Siz
/= 0 then
5876 CS
: constant Boolean := Comes_From_Source
(N
);
5879 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
5881 -- This integer literal is not a static expression. We do
5882 -- not call Analyze_And_Resolve here, because this would
5883 -- activate the circuit for deciding that a static value
5884 -- was out of range, and we don't want that.
5886 -- So just manually set the type, mark the expression as
5887 -- non-static, and then ensure that the result is checked
5888 -- properly if the attribute comes from source (if it was
5889 -- internally generated, we never need a constraint check).
5892 Set_Is_Static_Expression
(N
, False);
5895 Apply_Constraint_Check
(N
, Typ
);
5905 when Attribute_Storage_Pool
=>
5907 Make_Type_Conversion
(Loc
,
5908 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5909 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5910 Analyze_And_Resolve
(N
, Typ
);
5916 when Attribute_Storage_Size
=> Storage_Size
: declare
5917 Alloc_Op
: Entity_Id
:= Empty
;
5921 -- Access type case, always go to the root type
5923 -- The case of access types results in a value of zero for the case
5924 -- where no storage size attribute clause has been given. If a
5925 -- storage size has been given, then the attribute is converted
5926 -- to a reference to the variable used to hold this value.
5928 if Is_Access_Type
(Ptyp
) then
5929 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
5931 Make_Attribute_Reference
(Loc
,
5932 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5933 Attribute_Name
=> Name_Max
,
5934 Expressions
=> New_List
(
5935 Make_Integer_Literal
(Loc
, 0),
5938 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
5940 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
5942 -- If the access type is associated with a simple storage pool
5943 -- object, then attempt to locate the optional Storage_Size
5944 -- function of the simple storage pool type. If not found,
5945 -- then the result will default to zero.
5947 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
5948 Name_Simple_Storage_Pool_Type
))
5951 Pool_Type
: constant Entity_Id
:=
5952 Base_Type
(Etype
(Entity
(N
)));
5955 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
5956 while Present
(Alloc_Op
) loop
5957 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
5958 and then Present
(First_Formal
(Alloc_Op
))
5959 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
5964 Alloc_Op
:= Homonym
(Alloc_Op
);
5968 -- In the normal Storage_Pool case, retrieve the primitive
5969 -- function associated with the pool type.
5974 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
5975 Attribute_Name
(N
));
5978 -- If Storage_Size wasn't found (can only occur in the simple
5979 -- storage pool case), then simply use zero for the result.
5981 if not Present
(Alloc_Op
) then
5982 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5984 -- Otherwise, rewrite the allocator as a call to pool type's
5985 -- Storage_Size function.
5990 Make_Function_Call
(Loc
,
5992 New_Occurrence_Of
(Alloc_Op
, Loc
),
5994 Parameter_Associations
=> New_List
(
5996 (Associated_Storage_Pool
5997 (Root_Type
(Ptyp
)), Loc
)))));
6001 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6004 Analyze_And_Resolve
(N
, Typ
);
6006 -- For tasks, we retrieve the size directly from the TCB. The
6007 -- size may depend on a discriminant of the type, and therefore
6008 -- can be a per-object expression, so type-level information is
6009 -- not sufficient in general. There are four cases to consider:
6011 -- a) If the attribute appears within a task body, the designated
6012 -- TCB is obtained by a call to Self.
6014 -- b) If the prefix of the attribute is the name of a task object,
6015 -- the designated TCB is the one stored in the corresponding record.
6017 -- c) If the prefix is a task type, the size is obtained from the
6018 -- size variable created for each task type
6020 -- d) If no Storage_Size was specified for the type, there is no
6021 -- size variable, and the value is a system-specific default.
6024 if In_Open_Scopes
(Ptyp
) then
6026 -- Storage_Size (Self)
6030 Make_Function_Call
(Loc
,
6032 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6033 Parameter_Associations
=>
6035 Make_Function_Call
(Loc
,
6037 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6039 elsif not Is_Entity_Name
(Pref
)
6040 or else not Is_Type
(Entity
(Pref
))
6042 -- Storage_Size (Rec (Obj).Size)
6046 Make_Function_Call
(Loc
,
6048 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6049 Parameter_Associations
=>
6051 Make_Selected_Component
(Loc
,
6053 Unchecked_Convert_To
(
6054 Corresponding_Record_Type
(Ptyp
),
6055 New_Copy_Tree
(Pref
)),
6057 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6059 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6061 -- Static Storage_Size pragma given for type: retrieve value
6062 -- from its allocated storage variable.
6066 Make_Function_Call
(Loc
,
6067 Name
=> New_Occurrence_Of
(
6068 RTE
(RE_Adjust_Storage_Size
), Loc
),
6069 Parameter_Associations
=>
6072 Storage_Size_Variable
(Ptyp
), Loc
)))));
6074 -- Get system default
6078 Make_Function_Call
(Loc
,
6081 RTE
(RE_Default_Stack_Size
), Loc
))));
6084 Analyze_And_Resolve
(N
, Typ
);
6092 when Attribute_Stream_Size
=>
6094 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6095 Analyze_And_Resolve
(N
, Typ
);
6101 -- 1. Deal with enumeration types with holes.
6102 -- 2. For floating-point, generate call to attribute function.
6103 -- 3. For other cases, deal with constraint checking.
6105 when Attribute_Succ
=> Succ
: declare
6106 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6109 -- For enumeration types with non-standard representations, we
6110 -- expand typ'Succ (x) into
6112 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6114 -- If the representation is contiguous, we compute instead
6115 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6117 if Is_Enumeration_Type
(Ptyp
)
6118 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6120 if Has_Contiguous_Rep
(Etyp
) then
6122 Unchecked_Convert_To
(Ptyp
,
6125 Make_Integer_Literal
(Loc
,
6126 Enumeration_Rep
(First_Literal
(Ptyp
))),
6128 Make_Function_Call
(Loc
,
6131 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6133 Parameter_Associations
=>
6135 Unchecked_Convert_To
(Ptyp
,
6138 Unchecked_Convert_To
(Standard_Integer
,
6139 Relocate_Node
(First
(Exprs
))),
6141 Make_Integer_Literal
(Loc
, 1))),
6142 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
6144 -- Add Boolean parameter True, to request program errror if
6145 -- we have a bad representation on our hands. Add False if
6146 -- checks are suppressed.
6148 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6150 Make_Indexed_Component
(Loc
,
6153 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6154 Expressions
=> New_List
(
6157 Make_Function_Call
(Loc
,
6160 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6161 Parameter_Associations
=> Exprs
),
6162 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6165 Analyze_And_Resolve
(N
, Typ
);
6167 -- For floating-point, we transform 'Succ into a call to the Succ
6168 -- floating-point attribute function in Fat_xxx (xxx is root type)
6170 elsif Is_Floating_Point_Type
(Ptyp
) then
6171 Expand_Fpt_Attribute_R
(N
);
6172 Analyze_And_Resolve
(N
, Typ
);
6174 -- For modular types, nothing to do (no overflow, since wraps)
6176 elsif Is_Modular_Integer_Type
(Ptyp
) then
6179 -- For other types, if argument is marked as needing a range check or
6180 -- overflow checking is enabled, we must generate a check.
6182 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6183 or else Do_Range_Check
(First
(Exprs
))
6185 Set_Do_Range_Check
(First
(Exprs
), False);
6186 Expand_Pred_Succ_Attribute
(N
);
6194 -- Transforms X'Tag into a direct reference to the tag of X
6196 when Attribute_Tag
=> Tag
: declare
6198 Prefix_Is_Type
: Boolean;
6201 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6202 Ttyp
:= Entity
(Pref
);
6203 Prefix_Is_Type
:= True;
6206 Prefix_Is_Type
:= False;
6209 if Is_Class_Wide_Type
(Ttyp
) then
6210 Ttyp
:= Root_Type
(Ttyp
);
6213 Ttyp
:= Underlying_Type
(Ttyp
);
6215 -- Ada 2005: The type may be a synchronized tagged type, in which
6216 -- case the tag information is stored in the corresponding record.
6218 if Is_Concurrent_Type
(Ttyp
) then
6219 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6222 if Prefix_Is_Type
then
6224 -- For VMs we leave the type attribute unexpanded because
6225 -- there's not a dispatching table to reference.
6227 if Tagged_Type_Expansion
then
6229 Unchecked_Convert_To
(RTE
(RE_Tag
),
6231 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6232 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6235 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6236 -- references the primary tag of the actual object. If 'Tag is
6237 -- applied to class-wide interface objects we generate code that
6238 -- displaces "this" to reference the base of the object.
6240 elsif Comes_From_Source
(N
)
6241 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6242 and then Is_Interface
(Etype
(Prefix
(N
)))
6245 -- (To_Tag_Ptr (Prefix'Address)).all
6247 -- Note that Prefix'Address is recursively expanded into a call
6248 -- to Base_Address (Obj.Tag)
6250 -- Not needed for VM targets, since all handled by the VM
6252 if Tagged_Type_Expansion
then
6254 Make_Explicit_Dereference
(Loc
,
6255 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6256 Make_Attribute_Reference
(Loc
,
6257 Prefix
=> Relocate_Node
(Pref
),
6258 Attribute_Name
=> Name_Address
))));
6259 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6264 Make_Selected_Component
(Loc
,
6265 Prefix
=> Relocate_Node
(Pref
),
6267 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6268 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6276 -- Transforms 'Terminated attribute into a call to Terminated function
6278 when Attribute_Terminated
=> Terminated
: begin
6280 -- The prefix of Terminated is of a task interface class-wide type.
6282 -- terminated (Task_Id (Pref._disp_get_task_id));
6284 if Ada_Version
>= Ada_2005
6285 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6286 and then Is_Interface
(Ptyp
)
6287 and then Is_Task_Interface
(Ptyp
)
6290 Make_Function_Call
(Loc
,
6292 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6293 Parameter_Associations
=> New_List
(
6294 Make_Unchecked_Type_Conversion
(Loc
,
6296 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6298 Make_Selected_Component
(Loc
,
6300 New_Copy_Tree
(Pref
),
6302 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
6304 elsif Restricted_Profile
then
6306 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6310 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6313 Analyze_And_Resolve
(N
, Standard_Boolean
);
6320 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6321 -- unchecked conversion from (integral) type of X to type address.
6324 | Attribute_To_Address
6327 Unchecked_Convert_To
(RTE
(RE_Address
),
6328 Relocate_Node
(First
(Exprs
))));
6329 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6335 when Attribute_To_Any
=> To_Any
: declare
6336 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6337 Decls
: constant List_Id
:= New_List
;
6343 Relocate_Node
(First
(Exprs
))), Decls
));
6344 Insert_Actions
(N
, Decls
);
6345 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6352 -- Transforms 'Truncation into a call to the floating-point attribute
6353 -- function Truncation in Fat_xxx (where xxx is the root type).
6354 -- Expansion is avoided for cases the back end can handle directly.
6356 when Attribute_Truncation
=>
6357 if not Is_Inline_Floating_Point_Attribute
(N
) then
6358 Expand_Fpt_Attribute_R
(N
);
6365 when Attribute_TypeCode
=> TypeCode
: declare
6366 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6367 Decls
: constant List_Id
:= New_List
;
6369 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
6370 Insert_Actions
(N
, Decls
);
6371 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6374 -----------------------
6375 -- Unbiased_Rounding --
6376 -----------------------
6378 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6379 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6380 -- root type). Expansion is avoided for cases the back end can handle
6383 when Attribute_Unbiased_Rounding
=>
6384 if not Is_Inline_Floating_Point_Attribute
(N
) then
6385 Expand_Fpt_Attribute_R
(N
);
6392 when Attribute_Update
=>
6393 Expand_Update_Attribute
(N
);
6399 -- The processing for VADS_Size is shared with Size
6405 -- For enumeration types with a standard representation, and for all
6406 -- other types, Val is handled by the back end. For enumeration types
6407 -- with a non-standard representation we use the _Pos_To_Rep array that
6408 -- was created when the type was frozen.
6410 when Attribute_Val
=> Val
: declare
6411 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
6414 if Is_Enumeration_Type
(Etyp
)
6415 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6417 if Has_Contiguous_Rep
(Etyp
) then
6419 Rep_Node
: constant Node_Id
:=
6420 Unchecked_Convert_To
(Etyp
,
6423 Make_Integer_Literal
(Loc
,
6424 Enumeration_Rep
(First_Literal
(Etyp
))),
6426 (Convert_To
(Standard_Integer
,
6427 Relocate_Node
(First
(Exprs
))))));
6431 Unchecked_Convert_To
(Etyp
,
6434 Make_Integer_Literal
(Loc
,
6435 Enumeration_Rep
(First_Literal
(Etyp
))),
6437 Make_Function_Call
(Loc
,
6440 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6441 Parameter_Associations
=> New_List
(
6443 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
6448 Make_Indexed_Component
(Loc
,
6449 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
6450 Expressions
=> New_List
(
6451 Convert_To
(Standard_Integer
,
6452 Relocate_Node
(First
(Exprs
))))));
6455 Analyze_And_Resolve
(N
, Typ
);
6457 -- If the argument is marked as requiring a range check then generate
6460 elsif Do_Range_Check
(First
(Exprs
)) then
6461 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
6469 -- The code for valid is dependent on the particular types involved.
6470 -- See separate sections below for the generated code in each case.
6472 when Attribute_Valid
=> Valid
: declare
6473 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
6476 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
6477 -- Save the validity checking mode. We always turn off validity
6478 -- checking during process of 'Valid since this is one place
6479 -- where we do not want the implicit validity checks to intefere
6480 -- with the explicit validity check that the programmer is doing.
6482 function Make_Range_Test
return Node_Id
;
6483 -- Build the code for a range test of the form
6484 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6486 ---------------------
6487 -- Make_Range_Test --
6488 ---------------------
6490 function Make_Range_Test
return Node_Id
is
6491 Temp
: constant Node_Id
:= Duplicate_Subexpr
(Pref
);
6494 -- The value whose validity is being checked has been captured in
6495 -- an object declaration. We certainly don't want this object to
6496 -- appear valid because the declaration initializes it.
6498 if Is_Entity_Name
(Temp
) then
6499 Set_Is_Known_Valid
(Entity
(Temp
), False);
6505 Unchecked_Convert_To
(Btyp
, Temp
),
6509 Unchecked_Convert_To
(Btyp
,
6510 Make_Attribute_Reference
(Loc
,
6511 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6512 Attribute_Name
=> Name_First
)),
6514 Unchecked_Convert_To
(Btyp
,
6515 Make_Attribute_Reference
(Loc
,
6516 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6517 Attribute_Name
=> Name_Last
))));
6518 end Make_Range_Test
;
6520 -- Start of processing for Attribute_Valid
6523 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6524 -- will be handled by the back-end directly.
6526 if CodePeer_Mode
and then Comes_From_Source
(N
) then
6530 -- Turn off validity checks. We do not want any implicit validity
6531 -- checks to intefere with the explicit check from the attribute
6533 Validity_Checks_On
:= False;
6535 -- Retrieve the base type. Handle the case where the base type is a
6536 -- private enumeration type.
6538 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
6539 Btyp
:= Full_View
(Btyp
);
6542 -- Floating-point case. This case is handled by the Valid attribute
6543 -- code in the floating-point attribute run-time library.
6545 if Is_Floating_Point_Type
(Ptyp
) then
6546 Float_Valid
: declare
6550 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
6551 -- Return entity for Pkg.Nam
6553 --------------------
6554 -- Get_Fat_Entity --
6555 --------------------
6557 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
6558 Exp_Name
: constant Node_Id
:=
6559 Make_Selected_Component
(Loc
,
6560 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
6561 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
6563 Find_Selected_Component
(Exp_Name
);
6564 return Entity
(Exp_Name
);
6567 -- Start of processing for Float_Valid
6570 -- The C and AAMP back-ends handle Valid for fpt types
6572 if Modify_Tree_For_C
or else Float_Rep
(Btyp
) = AAMP
then
6573 Analyze_And_Resolve
(Pref
, Ptyp
);
6574 Set_Etype
(N
, Standard_Boolean
);
6578 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6580 -- If the prefix is a reverse SSO component, or is possibly
6581 -- unaligned, first create a temporary copy that is in
6582 -- native SSO, and properly aligned. Make it Volatile to
6583 -- prevent folding in the back-end. Note that we use an
6584 -- intermediate constrained string type to initialize the
6585 -- temporary, as the value at hand might be invalid, and in
6586 -- that case it cannot be copied using a floating point
6589 if In_Reverse_Storage_Order_Object
(Pref
)
6590 or else Is_Possibly_Unaligned_Object
(Pref
)
6593 Temp
: constant Entity_Id
:=
6594 Make_Temporary
(Loc
, 'F');
6596 Fat_S
: constant Entity_Id
:=
6597 Get_Fat_Entity
(Name_S
);
6598 -- Constrained string subtype of appropriate size
6600 Fat_P
: constant Entity_Id
:=
6601 Get_Fat_Entity
(Name_P
);
6604 Decl
: constant Node_Id
:=
6605 Make_Object_Declaration
(Loc
,
6606 Defining_Identifier
=> Temp
,
6607 Aliased_Present
=> True,
6608 Object_Definition
=>
6609 New_Occurrence_Of
(Ptyp
, Loc
));
6612 Set_Aspect_Specifications
(Decl
, New_List
(
6613 Make_Aspect_Specification
(Loc
,
6615 Make_Identifier
(Loc
, Name_Volatile
))));
6621 Make_Assignment_Statement
(Loc
,
6623 Make_Explicit_Dereference
(Loc
,
6625 Unchecked_Convert_To
(Fat_P
,
6626 Make_Attribute_Reference
(Loc
,
6628 New_Occurrence_Of
(Temp
, Loc
),
6630 Name_Unrestricted_Access
))),
6632 Unchecked_Convert_To
(Fat_S
,
6633 Relocate_Node
(Pref
)))),
6635 Suppress
=> All_Checks
);
6637 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
6641 -- We now have an object of the proper endianness and
6642 -- alignment, and can construct a Valid attribute.
6644 -- We make sure the prefix of this valid attribute is
6645 -- marked as not coming from source, to avoid losing
6646 -- warnings from 'Valid looking like a possible update.
6648 Set_Comes_From_Source
(Pref
, False);
6650 Expand_Fpt_Attribute
6651 (N
, Pkg
, Name_Valid
,
6653 Make_Attribute_Reference
(Loc
,
6654 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6655 Attribute_Name
=> Name_Unrestricted_Access
)));
6658 -- One more task, we still need a range check. Required
6659 -- only if we have a constraint, since the Valid routine
6660 -- catches infinities properly (infinities are never valid).
6662 -- The way we do the range check is simply to create the
6663 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6665 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
6668 Left_Opnd
=> Relocate_Node
(N
),
6671 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
6672 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6676 -- Enumeration type with holes
6678 -- For enumeration types with holes, the Pos value constructed by
6679 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6680 -- second argument of False returns minus one for an invalid value,
6681 -- and the non-negative pos value for a valid value, so the
6682 -- expansion of X'Valid is simply:
6684 -- type(X)'Pos (X) >= 0
6686 -- We can't quite generate it that way because of the requirement
6687 -- for the non-standard second argument of False in the resulting
6688 -- rep_to_pos call, so we have to explicitly create:
6690 -- _rep_to_pos (X, False) >= 0
6692 -- If we have an enumeration subtype, we also check that the
6693 -- value is in range:
6695 -- _rep_to_pos (X, False) >= 0
6697 -- (X >= type(X)'First and then type(X)'Last <= X)
6699 elsif Is_Enumeration_Type
(Ptyp
)
6700 and then Present
(Enum_Pos_To_Rep
(Btyp
))
6705 Make_Function_Call
(Loc
,
6707 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
6708 Parameter_Associations
=> New_List
(
6710 New_Occurrence_Of
(Standard_False
, Loc
))),
6711 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
6715 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
6717 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
6719 -- The call to Make_Range_Test will create declarations
6720 -- that need a proper insertion point, but Pref is now
6721 -- attached to a node with no ancestor. Attach to tree
6722 -- even if it is to be rewritten below.
6724 Set_Parent
(Tst
, Parent
(N
));
6728 Left_Opnd
=> Make_Range_Test
,
6734 -- Fortran convention booleans
6736 -- For the very special case of Fortran convention booleans, the
6737 -- value is always valid, since it is an integer with the semantics
6738 -- that non-zero is true, and any value is permissible.
6740 elsif Is_Boolean_Type
(Ptyp
)
6741 and then Convention
(Ptyp
) = Convention_Fortran
6743 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6745 -- For biased representations, we will be doing an unchecked
6746 -- conversion without unbiasing the result. That means that the range
6747 -- test has to take this into account, and the proper form of the
6750 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6752 elsif Has_Biased_Representation
(Ptyp
) then
6753 Btyp
:= RTE
(RE_Unsigned_32
);
6757 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
6759 Unchecked_Convert_To
(Btyp
,
6760 Make_Attribute_Reference
(Loc
,
6761 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6762 Attribute_Name
=> Name_Range_Length
))));
6764 -- For all other scalar types, what we want logically is a
6767 -- X in type(X)'First .. type(X)'Last
6769 -- But that's precisely what won't work because of possible
6770 -- unwanted optimization (and indeed the basic motivation for
6771 -- the Valid attribute is exactly that this test does not work).
6772 -- What will work is:
6774 -- Btyp!(X) >= Btyp!(type(X)'First)
6776 -- Btyp!(X) <= Btyp!(type(X)'Last)
6778 -- where Btyp is an integer type large enough to cover the full
6779 -- range of possible stored values (i.e. it is chosen on the basis
6780 -- of the size of the type, not the range of the values). We write
6781 -- this as two tests, rather than a range check, so that static
6782 -- evaluation will easily remove either or both of the checks if
6783 -- they can be -statically determined to be true (this happens
6784 -- when the type of X is static and the range extends to the full
6785 -- range of stored values).
6787 -- Unsigned types. Note: it is safe to consider only whether the
6788 -- subtype is unsigned, since we will in that case be doing all
6789 -- unsigned comparisons based on the subtype range. Since we use the
6790 -- actual subtype object size, this is appropriate.
6792 -- For example, if we have
6794 -- subtype x is integer range 1 .. 200;
6795 -- for x'Object_Size use 8;
6797 -- Now the base type is signed, but objects of this type are bits
6798 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6799 -- correct, even though a value greater than 127 looks signed to a
6800 -- signed comparison.
6802 elsif Is_Unsigned_Type
(Ptyp
) then
6803 if Esize
(Ptyp
) <= 32 then
6804 Btyp
:= RTE
(RE_Unsigned_32
);
6806 Btyp
:= RTE
(RE_Unsigned_64
);
6809 Rewrite
(N
, Make_Range_Test
);
6814 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6815 Btyp
:= Standard_Integer
;
6817 Btyp
:= Universal_Integer
;
6820 Rewrite
(N
, Make_Range_Test
);
6823 -- If a predicate is present, then we do the predicate test, even if
6824 -- within the predicate function (infinite recursion is warned about
6825 -- in Sem_Attr in that case).
6828 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6831 if Present
(Pred_Func
) then
6834 Left_Opnd
=> Relocate_Node
(N
),
6835 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6839 Analyze_And_Resolve
(N
, Standard_Boolean
);
6840 Validity_Checks_On
:= Save_Validity_Checks_On
;
6847 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6851 if Present
(Underlying_Type
(Ptyp
)) then
6852 Ftyp
:= Underlying_Type
(Ptyp
);
6857 -- Replace by True if no scalar parts
6859 if not Scalar_Part_Present
(Ftyp
) then
6860 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6862 -- For scalar types, Valid_Scalars is the same as Valid
6864 elsif Is_Scalar_Type
(Ftyp
) then
6866 Make_Attribute_Reference
(Loc
,
6867 Attribute_Name
=> Name_Valid
,
6870 -- For array types, we construct a function that determines if there
6871 -- are any non-valid scalar subcomponents, and call the function.
6872 -- We only do this for arrays whose component type needs checking
6874 elsif Is_Array_Type
(Ftyp
)
6875 and then Scalar_Part_Present
(Component_Type
(Ftyp
))
6878 Make_Function_Call
(Loc
,
6880 New_Occurrence_Of
(Build_Array_VS_Func
(Ftyp
, N
), Loc
),
6881 Parameter_Associations
=> New_List
(Pref
)));
6883 -- For record types, we construct a function that determines if there
6884 -- are any non-valid scalar subcomponents, and call the function.
6886 elsif Is_Record_Type
(Ftyp
)
6887 and then Nkind
(Type_Definition
(Declaration_Node
(Ftyp
))) =
6891 Make_Function_Call
(Loc
,
6893 New_Occurrence_Of
(Build_Record_VS_Func
(Ftyp
, N
), Loc
),
6894 Parameter_Associations
=> New_List
(Pref
)));
6896 -- Other record types or types with discriminants
6898 elsif Is_Record_Type
(Ftyp
) or else Has_Discriminants
(Ptyp
) then
6900 -- Build expression with list of equality tests
6908 X
:= New_Occurrence_Of
(Standard_True
, Loc
);
6909 C
:= First_Component_Or_Discriminant
(Ptyp
);
6910 while Present
(C
) loop
6911 if not Scalar_Part_Present
(Etype
(C
)) then
6913 elsif Is_Scalar_Type
(Etype
(C
)) then
6916 A
:= Name_Valid_Scalars
;
6923 Make_Attribute_Reference
(Loc
,
6924 Attribute_Name
=> A
,
6926 Make_Selected_Component
(Loc
,
6928 Duplicate_Subexpr
(Pref
, Name_Req
=> True),
6930 New_Occurrence_Of
(C
, Loc
))));
6932 Next_Component_Or_Discriminant
(C
);
6938 -- For all other types, result is True
6941 Rewrite
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
6944 -- Result is always boolean, but never static
6946 Analyze_And_Resolve
(N
, Standard_Boolean
);
6947 Set_Is_Static_Expression
(N
, False);
6954 -- Value attribute is handled in separate unit Exp_Imgv
6956 when Attribute_Value
=>
6957 Exp_Imgv
.Expand_Value_Attribute
(N
);
6963 -- The processing for Value_Size shares the processing for Size
6969 -- The processing for Version shares the processing for Body_Version
6975 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6977 when Attribute_Wide_Image
=>
6978 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
6980 ---------------------
6981 -- Wide_Wide_Image --
6982 ---------------------
6984 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6986 when Attribute_Wide_Wide_Image
=>
6987 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
6993 -- We expand typ'Wide_Value (X) into
6996 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6998 -- Wide_String_To_String is a runtime function that converts its wide
6999 -- string argument to String, converting any non-translatable characters
7000 -- into appropriate escape sequences. This preserves the required
7001 -- semantics of Wide_Value in all cases, and results in a very simple
7002 -- implementation approach.
7004 -- Note: for this approach to be fully standard compliant for the cases
7005 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7006 -- method must cover the entire character range (e.g. UTF-8). But that
7007 -- is a reasonable requirement when dealing with encoded character
7008 -- sequences. Presumably if one of the restrictive encoding mechanisms
7009 -- is in use such as Shift-JIS, then characters that cannot be
7010 -- represented using this encoding will not appear in any case.
7012 when Attribute_Wide_Value
=>
7014 Make_Attribute_Reference
(Loc
,
7016 Attribute_Name
=> Name_Value
,
7018 Expressions
=> New_List
(
7019 Make_Function_Call
(Loc
,
7021 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7023 Parameter_Associations
=> New_List
(
7024 Relocate_Node
(First
(Exprs
)),
7025 Make_Integer_Literal
(Loc
,
7026 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7028 Analyze_And_Resolve
(N
, Typ
);
7030 ---------------------
7031 -- Wide_Wide_Value --
7032 ---------------------
7034 -- We expand typ'Wide_Value_Value (X) into
7037 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7039 -- Wide_Wide_String_To_String is a runtime function that converts its
7040 -- wide string argument to String, converting any non-translatable
7041 -- characters into appropriate escape sequences. This preserves the
7042 -- required semantics of Wide_Wide_Value in all cases, and results in a
7043 -- very simple implementation approach.
7045 -- It's not quite right where typ = Wide_Wide_Character, because the
7046 -- encoding method may not cover the whole character type ???
7048 when Attribute_Wide_Wide_Value
=>
7050 Make_Attribute_Reference
(Loc
,
7052 Attribute_Name
=> Name_Value
,
7054 Expressions
=> New_List
(
7055 Make_Function_Call
(Loc
,
7058 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7060 Parameter_Associations
=> New_List
(
7061 Relocate_Node
(First
(Exprs
)),
7062 Make_Integer_Literal
(Loc
,
7063 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7065 Analyze_And_Resolve
(N
, Typ
);
7067 ---------------------
7068 -- Wide_Wide_Width --
7069 ---------------------
7071 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7073 when Attribute_Wide_Wide_Width
=>
7074 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7080 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7082 when Attribute_Wide_Width
=>
7083 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7089 -- Width attribute is handled in separate unit Exp_Imgv
7091 when Attribute_Width
=>
7092 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7098 when Attribute_Write
=> Write
: declare
7099 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7100 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7108 -- If no underlying type, we have an error that will be diagnosed
7109 -- elsewhere, so here we just completely ignore the expansion.
7115 -- Stream operations can appear in user code even if the restriction
7116 -- No_Streams is active (for example, when instantiating a predefined
7117 -- container). In that case rewrite the attribute as a Raise to
7118 -- prevent any run-time use.
7120 if Restriction_Active
(No_Streams
) then
7122 Make_Raise_Program_Error
(Sloc
(N
),
7123 Reason
=> PE_Stream_Operation_Not_Allowed
));
7124 Set_Etype
(N
, U_Type
);
7128 -- The simple case, if there is a TSS for Write, just call it
7130 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7132 if Present
(Pname
) then
7136 -- If there is a Stream_Convert pragma, use it, we rewrite
7138 -- sourcetyp'Output (stream, Item)
7142 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7144 -- where strmwrite is the given Write function that converts an
7145 -- argument of type sourcetyp or a type acctyp, from which it is
7146 -- derived to type strmtyp. The conversion to acttyp is required
7147 -- for the derived case.
7149 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7151 if Present
(Prag
) then
7153 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7154 Wfunc
:= Entity
(Expression
(Arg3
));
7157 Make_Attribute_Reference
(Loc
,
7158 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7159 Attribute_Name
=> Name_Output
,
7160 Expressions
=> New_List
(
7161 Relocate_Node
(First
(Exprs
)),
7162 Make_Function_Call
(Loc
,
7163 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7164 Parameter_Associations
=> New_List
(
7165 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7166 Relocate_Node
(Next
(First
(Exprs
)))))))));
7171 -- For elementary types, we call the W_xxx routine directly
7173 elsif Is_Elementary_Type
(U_Type
) then
7174 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7180 elsif Is_Array_Type
(U_Type
) then
7181 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7182 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
7184 -- Tagged type case, use the primitive Write function. Note that
7185 -- this will dispatch in the class-wide case which is what we want
7187 elsif Is_Tagged_Type
(U_Type
) then
7188 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7190 -- All other record type cases, including protected records.
7191 -- The latter only arise for expander generated code for
7192 -- handling shared passive partition access.
7196 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7198 -- Ada 2005 (AI-216): Program_Error is raised when executing
7199 -- the default implementation of the Write attribute of an
7200 -- Unchecked_Union type. However, if the 'Write reference is
7201 -- within the generated Output stream procedure, Write outputs
7202 -- the components, and the default values of the discriminant
7203 -- are streamed by the Output procedure itself.
7205 if Is_Unchecked_Union
(Base_Type
(U_Type
))
7206 and not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7209 Make_Raise_Program_Error
(Loc
,
7210 Reason
=> PE_Unchecked_Union_Restriction
));
7213 if Has_Discriminants
(U_Type
)
7215 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
7217 Build_Mutable_Record_Write_Procedure
7218 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7220 Build_Record_Write_Procedure
7221 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7224 Insert_Action
(N
, Decl
);
7228 -- If we fall through, Pname is the procedure to be called
7230 Rewrite_Stream_Proc_Call
(Pname
);
7233 -- Component_Size is handled by the back end, unless the component size
7234 -- is known at compile time, which is always true in the packed array
7235 -- case. It is important that the packed array case is handled in the
7236 -- front end (see Eval_Attribute) since the back end would otherwise get
7237 -- confused by the equivalent packed array type.
7239 when Attribute_Component_Size
=>
7242 -- The following attributes are handled by the back end (except that
7243 -- static cases have already been evaluated during semantic processing,
7244 -- but in any case the back end should not count on this).
7246 -- The back end also handles the non-class-wide cases of Size
7248 when Attribute_Bit_Order
7249 | Attribute_Code_Address
7250 | Attribute_Definite
7252 | Attribute_Null_Parameter
7253 | Attribute_Passed_By_Reference
7254 | Attribute_Pool_Address
7255 | Attribute_Scalar_Storage_Order
7259 -- The following attributes are also handled by the back end, but return
7260 -- a universal integer result, so may need a conversion for checking
7261 -- that the result is in range.
7264 | Attribute_Max_Alignment_For_Allocation
7266 Apply_Universal_Integer_Attribute_Checks
(N
);
7268 -- The following attributes should not appear at this stage, since they
7269 -- have already been handled by the analyzer (and properly rewritten
7270 -- with corresponding values or entities to represent the right values)
7272 when Attribute_Abort_Signal
7273 | Attribute_Address_Size
7274 | Attribute_Atomic_Always_Lock_Free
7277 | Attribute_Compiler_Version
7278 | Attribute_Default_Bit_Order
7279 | Attribute_Default_Scalar_Storage_Order
7286 | Attribute_Fast_Math
7287 | Attribute_First_Valid
7288 | Attribute_Has_Access_Values
7289 | Attribute_Has_Discriminants
7290 | Attribute_Has_Tagged_Values
7292 | Attribute_Last_Valid
7293 | Attribute_Library_Level
7294 | Attribute_Lock_Free
7295 | Attribute_Machine_Emax
7296 | Attribute_Machine_Emin
7297 | Attribute_Machine_Mantissa
7298 | Attribute_Machine_Overflows
7299 | Attribute_Machine_Radix
7300 | Attribute_Machine_Rounds
7301 | Attribute_Maximum_Alignment
7302 | Attribute_Model_Emin
7303 | Attribute_Model_Epsilon
7304 | Attribute_Model_Mantissa
7305 | Attribute_Model_Small
7307 | Attribute_Partition_ID
7309 | Attribute_Restriction_Set
7310 | Attribute_Safe_Emax
7311 | Attribute_Safe_First
7312 | Attribute_Safe_Large
7313 | Attribute_Safe_Last
7314 | Attribute_Safe_Small
7316 | Attribute_Signed_Zeros
7318 | Attribute_Storage_Unit
7319 | Attribute_Stub_Type
7320 | Attribute_System_Allocator_Alignment
7321 | Attribute_Target_Name
7322 | Attribute_Type_Class
7323 | Attribute_Type_Key
7324 | Attribute_Unconstrained_Array
7325 | Attribute_Universal_Literal_String
7326 | Attribute_Wchar_T_Size
7327 | Attribute_Word_Size
7329 raise Program_Error
;
7331 -- The Asm_Input and Asm_Output attributes are not expanded at this
7332 -- stage, but will be eliminated in the expansion of the Asm call, see
7333 -- Exp_Intr for details. So the back end will never see these either.
7335 when Attribute_Asm_Input
7336 | Attribute_Asm_Output
7341 -- Note: as mentioned earlier, individual sections of the above case
7342 -- statement assume there is no code after the case statement, and are
7343 -- legitimately allowed to execute return statements if they have nothing
7344 -- more to do, so DO NOT add code at this point.
7347 when RE_Not_Available
=>
7349 end Expand_N_Attribute_Reference
;
7351 --------------------------------
7352 -- Expand_Pred_Succ_Attribute --
7353 --------------------------------
7355 -- For typ'Pred (exp), we generate the check
7357 -- [constraint_error when exp = typ'Base'First]
7359 -- Similarly, for typ'Succ (exp), we generate the check
7361 -- [constraint_error when exp = typ'Base'Last]
7363 -- These checks are not generated for modular types, since the proper
7364 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7365 -- We also suppress these checks if we are the right side of an assignment
7366 -- statement or the expression of an object declaration, where the flag
7367 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7369 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
7370 Loc
: constant Source_Ptr
:= Sloc
(N
);
7371 P
: constant Node_Id
:= Parent
(N
);
7375 if Attribute_Name
(N
) = Name_Pred
then
7381 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
7382 or else not Suppress_Assignment_Checks
(P
)
7385 Make_Raise_Constraint_Error
(Loc
,
7389 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
7391 Make_Attribute_Reference
(Loc
,
7393 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
7394 Attribute_Name
=> Cnam
)),
7395 Reason
=> CE_Overflow_Check_Failed
));
7397 end Expand_Pred_Succ_Attribute
;
7399 -----------------------------
7400 -- Expand_Update_Attribute --
7401 -----------------------------
7403 procedure Expand_Update_Attribute
(N
: Node_Id
) is
7404 procedure Process_Component_Or_Element_Update
7409 -- Generate the statements necessary to update a single component or an
7410 -- element of the prefix. The code is inserted before the attribute N.
7411 -- Temp denotes the entity of the anonymous object created to reflect
7412 -- the changes in values. Comp is the component/index expression to be
7413 -- updated. Expr is an expression yielding the new value of Comp. Typ
7414 -- is the type of the prefix of attribute Update.
7416 procedure Process_Range_Update
7421 -- Generate the statements necessary to update a slice of the prefix.
7422 -- The code is inserted before the attribute N. Temp denotes the entity
7423 -- of the anonymous object created to reflect the changes in values.
7424 -- Comp is range of the slice to be updated. Expr is an expression
7425 -- yielding the new value of Comp. Typ is the type of the prefix of
7426 -- attribute Update.
7428 -----------------------------------------
7429 -- Process_Component_Or_Element_Update --
7430 -----------------------------------------
7432 procedure Process_Component_Or_Element_Update
7438 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7443 -- An array element may be modified by the following relations
7444 -- depending on the number of dimensions:
7446 -- 1 => Expr -- one dimensional update
7447 -- (1, ..., N) => Expr -- multi dimensional update
7449 -- The above forms are converted in assignment statements where the
7450 -- left hand side is an indexed component:
7452 -- Temp (1) := Expr; -- one dimensional update
7453 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7455 if Is_Array_Type
(Typ
) then
7457 -- The index expressions of a multi dimensional array update
7458 -- appear as an aggregate.
7460 if Nkind
(Comp
) = N_Aggregate
then
7461 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
7463 Exprs
:= New_List
(Relocate_Node
(Comp
));
7467 Make_Indexed_Component
(Loc
,
7468 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7469 Expressions
=> Exprs
);
7471 -- A record component update appears in the following form:
7475 -- The above relation is transformed into an assignment statement
7476 -- where the left hand side is a selected component:
7478 -- Temp.Comp := Expr;
7480 else pragma Assert
(Is_Record_Type
(Typ
));
7482 Make_Selected_Component
(Loc
,
7483 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7484 Selector_Name
=> Relocate_Node
(Comp
));
7488 Make_Assignment_Statement
(Loc
,
7490 Expression
=> Relocate_Node
(Expr
)));
7491 end Process_Component_Or_Element_Update
;
7493 --------------------------
7494 -- Process_Range_Update --
7495 --------------------------
7497 procedure Process_Range_Update
7503 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
7504 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7508 -- A range update appears as
7510 -- (Low .. High => Expr)
7512 -- The above construct is transformed into a loop that iterates over
7513 -- the given range and modifies the corresponding array values to the
7516 -- for Index in Low .. High loop
7517 -- Temp (<Index_Typ> (Index)) := Expr;
7520 Index
:= Make_Temporary
(Loc
, 'I');
7523 Make_Loop_Statement
(Loc
,
7525 Make_Iteration_Scheme
(Loc
,
7526 Loop_Parameter_Specification
=>
7527 Make_Loop_Parameter_Specification
(Loc
,
7528 Defining_Identifier
=> Index
,
7529 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
7531 Statements
=> New_List
(
7532 Make_Assignment_Statement
(Loc
,
7534 Make_Indexed_Component
(Loc
,
7535 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7536 Expressions
=> New_List
(
7537 Convert_To
(Index_Typ
,
7538 New_Occurrence_Of
(Index
, Loc
)))),
7539 Expression
=> Relocate_Node
(Expr
))),
7541 End_Label
=> Empty
));
7542 end Process_Range_Update
;
7546 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
7547 Loc
: constant Source_Ptr
:= Sloc
(N
);
7548 Pref
: constant Node_Id
:= Prefix
(N
);
7549 Typ
: constant Entity_Id
:= Etype
(Pref
);
7552 CW_Temp
: Entity_Id
;
7557 -- Start of processing for Expand_Update_Attribute
7560 -- Create the anonymous object to store the value of the prefix and
7561 -- capture subsequent changes in value.
7563 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
7565 -- Preserve the tag of the prefix by offering a specific view of the
7566 -- class-wide version of the prefix.
7568 if Is_Tagged_Type
(Typ
) then
7571 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7573 CW_Temp
:= Make_Temporary
(Loc
, 'T');
7574 CW_Typ
:= Class_Wide_Type
(Typ
);
7577 Make_Object_Declaration
(Loc
,
7578 Defining_Identifier
=> CW_Temp
,
7579 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
7581 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
7584 -- Temp : Typ renames Typ (CW_Temp);
7587 Make_Object_Renaming_Declaration
(Loc
,
7588 Defining_Identifier
=> Temp
,
7589 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
7591 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
7597 -- Temp : Typ := Pref;
7600 Make_Object_Declaration
(Loc
,
7601 Defining_Identifier
=> Temp
,
7602 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7603 Expression
=> Relocate_Node
(Pref
)));
7606 -- Process the update aggregate
7608 Assoc
:= First
(Component_Associations
(Aggr
));
7609 while Present
(Assoc
) loop
7610 Comp
:= First
(Choices
(Assoc
));
7611 Expr
:= Expression
(Assoc
);
7612 while Present
(Comp
) loop
7613 if Nkind
(Comp
) = N_Range
then
7614 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
7616 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
7625 -- The attribute is replaced by a reference to the anonymous object
7627 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7629 end Expand_Update_Attribute
;
7635 procedure Find_Fat_Info
7637 Fat_Type
: out Entity_Id
;
7638 Fat_Pkg
: out RE_Id
)
7640 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
7643 -- All we do is use the root type (historically this dealt with
7644 -- VAX-float .. to be cleaned up further later ???)
7648 if Fat_Type
= Standard_Short_Float
then
7649 Fat_Pkg
:= RE_Attr_Short_Float
;
7651 elsif Fat_Type
= Standard_Float
then
7652 Fat_Pkg
:= RE_Attr_Float
;
7654 elsif Fat_Type
= Standard_Long_Float
then
7655 Fat_Pkg
:= RE_Attr_Long_Float
;
7657 elsif Fat_Type
= Standard_Long_Long_Float
then
7658 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7660 -- Universal real (which is its own root type) is treated as being
7661 -- equivalent to Standard.Long_Long_Float, since it is defined to
7662 -- have the same precision as the longest Float type.
7664 elsif Fat_Type
= Universal_Real
then
7665 Fat_Type
:= Standard_Long_Long_Float
;
7666 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7669 raise Program_Error
;
7673 ----------------------------
7674 -- Find_Stream_Subprogram --
7675 ----------------------------
7677 function Find_Stream_Subprogram
7679 Nam
: TSS_Name_Type
) return Entity_Id
7681 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7682 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
7684 function Is_Available
(Entity
: RE_Id
) return Boolean;
7685 pragma Inline
(Is_Available
);
7686 -- Function to check whether the specified run-time call is available
7687 -- in the run time used. In the case of a configurable run time, it
7688 -- is normal that some subprograms are not there.
7690 -- I don't understand this routine at all, why is this not just a
7691 -- call to RTE_Available? And if for some reason we need a different
7692 -- routine with different semantics, why is not in Rtsfind ???
7698 function Is_Available
(Entity
: RE_Id
) return Boolean is
7700 -- Assume that the unit will always be available when using a
7701 -- "normal" (not configurable) run time.
7703 return not Configurable_Run_Time_Mode
or else RTE_Available
(Entity
);
7706 -- Start of processing for Find_Stream_Subprogram
7709 if Present
(Ent
) then
7713 -- Stream attributes for strings are expanded into library calls. The
7714 -- following checks are disabled when the run-time is not available or
7715 -- when compiling predefined types due to bootstrap issues. As a result,
7716 -- the compiler will generate in-place stream routines for string types
7717 -- that appear in GNAT's library, but will generate calls via rtsfind
7718 -- to library routines for user code.
7720 -- Note: In the case of using a configurable run time, it is very likely
7721 -- that stream routines for string types are not present (they require
7722 -- file system support). In this case, the specific stream routines for
7723 -- strings are not used, relying on the regular stream mechanism
7724 -- instead. That is why we include the test Is_Available when dealing
7725 -- with these cases.
7727 if not Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
)) then
7728 -- Storage_Array as defined in package System.Storage_Elements
7730 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
7732 -- Case of No_Stream_Optimizations restriction active
7734 if Restriction_Active
(No_Stream_Optimizations
) then
7735 if Nam
= TSS_Stream_Input
7736 and then Is_Available
(RE_Storage_Array_Input
)
7738 return RTE
(RE_Storage_Array_Input
);
7740 elsif Nam
= TSS_Stream_Output
7741 and then Is_Available
(RE_Storage_Array_Output
)
7743 return RTE
(RE_Storage_Array_Output
);
7745 elsif Nam
= TSS_Stream_Read
7746 and then Is_Available
(RE_Storage_Array_Read
)
7748 return RTE
(RE_Storage_Array_Read
);
7750 elsif Nam
= TSS_Stream_Write
7751 and then Is_Available
(RE_Storage_Array_Write
)
7753 return RTE
(RE_Storage_Array_Write
);
7755 elsif Nam
/= TSS_Stream_Input
and then
7756 Nam
/= TSS_Stream_Output
and then
7757 Nam
/= TSS_Stream_Read
and then
7758 Nam
/= TSS_Stream_Write
7760 raise Program_Error
;
7763 -- Restriction No_Stream_Optimizations is not set, so we can go
7764 -- ahead and optimize using the block IO forms of the routines.
7767 if Nam
= TSS_Stream_Input
7768 and then Is_Available
(RE_Storage_Array_Input_Blk_IO
)
7770 return RTE
(RE_Storage_Array_Input_Blk_IO
);
7772 elsif Nam
= TSS_Stream_Output
7773 and then Is_Available
(RE_Storage_Array_Output_Blk_IO
)
7775 return RTE
(RE_Storage_Array_Output_Blk_IO
);
7777 elsif Nam
= TSS_Stream_Read
7778 and then Is_Available
(RE_Storage_Array_Read_Blk_IO
)
7780 return RTE
(RE_Storage_Array_Read_Blk_IO
);
7782 elsif Nam
= TSS_Stream_Write
7783 and then Is_Available
(RE_Storage_Array_Write_Blk_IO
)
7785 return RTE
(RE_Storage_Array_Write_Blk_IO
);
7787 elsif Nam
/= TSS_Stream_Input
and then
7788 Nam
/= TSS_Stream_Output
and then
7789 Nam
/= TSS_Stream_Read
and then
7790 Nam
/= TSS_Stream_Write
7792 raise Program_Error
;
7796 -- Stream_Element_Array as defined in package Ada.Streams
7798 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
7800 -- Case of No_Stream_Optimizations restriction active
7802 if Restriction_Active
(No_Stream_Optimizations
) then
7803 if Nam
= TSS_Stream_Input
7804 and then Is_Available
(RE_Stream_Element_Array_Input
)
7806 return RTE
(RE_Stream_Element_Array_Input
);
7808 elsif Nam
= TSS_Stream_Output
7809 and then Is_Available
(RE_Stream_Element_Array_Output
)
7811 return RTE
(RE_Stream_Element_Array_Output
);
7813 elsif Nam
= TSS_Stream_Read
7814 and then Is_Available
(RE_Stream_Element_Array_Read
)
7816 return RTE
(RE_Stream_Element_Array_Read
);
7818 elsif Nam
= TSS_Stream_Write
7819 and then Is_Available
(RE_Stream_Element_Array_Write
)
7821 return RTE
(RE_Stream_Element_Array_Write
);
7823 elsif Nam
/= TSS_Stream_Input
and then
7824 Nam
/= TSS_Stream_Output
and then
7825 Nam
/= TSS_Stream_Read
and then
7826 Nam
/= TSS_Stream_Write
7828 raise Program_Error
;
7831 -- Restriction No_Stream_Optimizations is not set, so we can go
7832 -- ahead and optimize using the block IO forms of the routines.
7835 if Nam
= TSS_Stream_Input
7836 and then Is_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
7838 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
7840 elsif Nam
= TSS_Stream_Output
7841 and then Is_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
7843 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
7845 elsif Nam
= TSS_Stream_Read
7846 and then Is_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
7848 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
7850 elsif Nam
= TSS_Stream_Write
7851 and then Is_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
7853 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
7855 elsif Nam
/= TSS_Stream_Input
and then
7856 Nam
/= TSS_Stream_Output
and then
7857 Nam
/= TSS_Stream_Read
and then
7858 Nam
/= TSS_Stream_Write
7860 raise Program_Error
;
7864 -- String as defined in package Ada
7866 elsif Base_Typ
= Standard_String
then
7868 -- Case of No_Stream_Optimizations restriction active
7870 if Restriction_Active
(No_Stream_Optimizations
) then
7871 if Nam
= TSS_Stream_Input
7872 and then Is_Available
(RE_String_Input
)
7874 return RTE
(RE_String_Input
);
7876 elsif Nam
= TSS_Stream_Output
7877 and then Is_Available
(RE_String_Output
)
7879 return RTE
(RE_String_Output
);
7881 elsif Nam
= TSS_Stream_Read
7882 and then Is_Available
(RE_String_Read
)
7884 return RTE
(RE_String_Read
);
7886 elsif Nam
= TSS_Stream_Write
7887 and then Is_Available
(RE_String_Write
)
7889 return RTE
(RE_String_Write
);
7891 elsif Nam
/= TSS_Stream_Input
and then
7892 Nam
/= TSS_Stream_Output
and then
7893 Nam
/= TSS_Stream_Read
and then
7894 Nam
/= TSS_Stream_Write
7896 raise Program_Error
;
7899 -- Restriction No_Stream_Optimizations is not set, so we can go
7900 -- ahead and optimize using the block IO forms of the routines.
7903 if Nam
= TSS_Stream_Input
7904 and then Is_Available
(RE_String_Input_Blk_IO
)
7906 return RTE
(RE_String_Input_Blk_IO
);
7908 elsif Nam
= TSS_Stream_Output
7909 and then Is_Available
(RE_String_Output_Blk_IO
)
7911 return RTE
(RE_String_Output_Blk_IO
);
7913 elsif Nam
= TSS_Stream_Read
7914 and then Is_Available
(RE_String_Read_Blk_IO
)
7916 return RTE
(RE_String_Read_Blk_IO
);
7918 elsif Nam
= TSS_Stream_Write
7919 and then Is_Available
(RE_String_Write_Blk_IO
)
7921 return RTE
(RE_String_Write_Blk_IO
);
7923 elsif Nam
/= TSS_Stream_Input
and then
7924 Nam
/= TSS_Stream_Output
and then
7925 Nam
/= TSS_Stream_Read
and then
7926 Nam
/= TSS_Stream_Write
7928 raise Program_Error
;
7932 -- Wide_String as defined in package Ada
7934 elsif Base_Typ
= Standard_Wide_String
then
7936 -- Case of No_Stream_Optimizations restriction active
7938 if Restriction_Active
(No_Stream_Optimizations
) then
7939 if Nam
= TSS_Stream_Input
7940 and then Is_Available
(RE_Wide_String_Input
)
7942 return RTE
(RE_Wide_String_Input
);
7944 elsif Nam
= TSS_Stream_Output
7945 and then Is_Available
(RE_Wide_String_Output
)
7947 return RTE
(RE_Wide_String_Output
);
7949 elsif Nam
= TSS_Stream_Read
7950 and then Is_Available
(RE_Wide_String_Read
)
7952 return RTE
(RE_Wide_String_Read
);
7954 elsif Nam
= TSS_Stream_Write
7955 and then Is_Available
(RE_Wide_String_Write
)
7957 return RTE
(RE_Wide_String_Write
);
7959 elsif Nam
/= TSS_Stream_Input
and then
7960 Nam
/= TSS_Stream_Output
and then
7961 Nam
/= TSS_Stream_Read
and then
7962 Nam
/= TSS_Stream_Write
7964 raise Program_Error
;
7967 -- Restriction No_Stream_Optimizations is not set, so we can go
7968 -- ahead and optimize using the block IO forms of the routines.
7971 if Nam
= TSS_Stream_Input
7972 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
7974 return RTE
(RE_Wide_String_Input_Blk_IO
);
7976 elsif Nam
= TSS_Stream_Output
7977 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
7979 return RTE
(RE_Wide_String_Output_Blk_IO
);
7981 elsif Nam
= TSS_Stream_Read
7982 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
7984 return RTE
(RE_Wide_String_Read_Blk_IO
);
7986 elsif Nam
= TSS_Stream_Write
7987 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
7989 return RTE
(RE_Wide_String_Write_Blk_IO
);
7991 elsif Nam
/= TSS_Stream_Input
and then
7992 Nam
/= TSS_Stream_Output
and then
7993 Nam
/= TSS_Stream_Read
and then
7994 Nam
/= TSS_Stream_Write
7996 raise Program_Error
;
8000 -- Wide_Wide_String as defined in package Ada
8002 elsif Base_Typ
= Standard_Wide_Wide_String
then
8004 -- Case of No_Stream_Optimizations restriction active
8006 if Restriction_Active
(No_Stream_Optimizations
) then
8007 if Nam
= TSS_Stream_Input
8008 and then Is_Available
(RE_Wide_Wide_String_Input
)
8010 return RTE
(RE_Wide_Wide_String_Input
);
8012 elsif Nam
= TSS_Stream_Output
8013 and then Is_Available
(RE_Wide_Wide_String_Output
)
8015 return RTE
(RE_Wide_Wide_String_Output
);
8017 elsif Nam
= TSS_Stream_Read
8018 and then Is_Available
(RE_Wide_Wide_String_Read
)
8020 return RTE
(RE_Wide_Wide_String_Read
);
8022 elsif Nam
= TSS_Stream_Write
8023 and then Is_Available
(RE_Wide_Wide_String_Write
)
8025 return RTE
(RE_Wide_Wide_String_Write
);
8027 elsif Nam
/= TSS_Stream_Input
and then
8028 Nam
/= TSS_Stream_Output
and then
8029 Nam
/= TSS_Stream_Read
and then
8030 Nam
/= TSS_Stream_Write
8032 raise Program_Error
;
8035 -- Restriction No_Stream_Optimizations is not set, so we can go
8036 -- ahead and optimize using the block IO forms of the routines.
8039 if Nam
= TSS_Stream_Input
8040 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8042 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8044 elsif Nam
= TSS_Stream_Output
8045 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8047 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8049 elsif Nam
= TSS_Stream_Read
8050 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8052 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8054 elsif Nam
= TSS_Stream_Write
8055 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8057 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8059 elsif Nam
/= TSS_Stream_Input
and then
8060 Nam
/= TSS_Stream_Output
and then
8061 Nam
/= TSS_Stream_Read
and then
8062 Nam
/= TSS_Stream_Write
8064 raise Program_Error
;
8070 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8071 return Find_Prim_Op
(Typ
, Nam
);
8073 return Find_Inherited_TSS
(Typ
, Nam
);
8075 end Find_Stream_Subprogram
;
8081 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8085 BT
:= Base_Type
(T
);
8087 if Is_Private_Type
(BT
)
8088 and then Present
(Full_View
(BT
))
8090 BT
:= Full_View
(BT
);
8096 -----------------------
8097 -- Get_Index_Subtype --
8098 -----------------------
8100 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
8101 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
8106 if Is_Access_Type
(P_Type
) then
8107 P_Type
:= Designated_Type
(P_Type
);
8110 if No
(Expressions
(N
)) then
8113 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
8116 Indx
:= First_Index
(P_Type
);
8122 return Etype
(Indx
);
8123 end Get_Index_Subtype
;
8125 -------------------------------
8126 -- Get_Stream_Convert_Pragma --
8127 -------------------------------
8129 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8134 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8135 -- that a stream convert pragma for a tagged type is not inherited from
8136 -- its parent. Probably what is wrong here is that it is basically
8137 -- incorrect to consider a stream convert pragma to be a representation
8138 -- pragma at all ???
8140 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8141 while Present
(N
) loop
8142 if Nkind
(N
) = N_Pragma
8143 and then Pragma_Name
(N
) = Name_Stream_Convert
8145 -- For tagged types this pragma is not inherited, so we
8146 -- must verify that it is defined for the given type and
8150 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8152 if not Is_Tagged_Type
(T
)
8154 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8164 end Get_Stream_Convert_Pragma
;
8166 ---------------------------------
8167 -- Is_Constrained_Packed_Array --
8168 ---------------------------------
8170 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8171 Arr
: Entity_Id
:= Typ
;
8174 if Is_Access_Type
(Arr
) then
8175 Arr
:= Designated_Type
(Arr
);
8178 return Is_Array_Type
(Arr
)
8179 and then Is_Constrained
(Arr
)
8180 and then Present
(Packed_Array_Impl_Type
(Arr
));
8181 end Is_Constrained_Packed_Array
;
8183 ----------------------------------------
8184 -- Is_Inline_Floating_Point_Attribute --
8185 ----------------------------------------
8187 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8188 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8190 function Is_GCC_Target
return Boolean;
8191 -- Return True if we are using a GCC target/back-end
8192 -- ??? Note: the implementation is kludgy/fragile
8198 function Is_GCC_Target
return Boolean is
8200 return not CodePeer_Mode
8201 and then not AAMP_On_Target
8202 and then not Modify_Tree_For_C
;
8205 -- Start of processing for Is_Inline_Floating_Point_Attribute
8208 -- Machine and Model can be expanded by the GCC and AAMP back ends only
8210 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8211 return Is_GCC_Target
or else AAMP_On_Target
;
8213 -- Remaining cases handled by all back ends are Rounding and Truncation
8214 -- when appearing as the operand of a conversion to some integer type.
8216 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8217 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8222 -- Here we are in the integer conversion context
8224 -- Very probably we should also recognize the cases of Machine_Rounding
8225 -- and unbiased rounding in this conversion context, but the back end is
8226 -- not yet prepared to handle these cases ???
8228 return Id
= Attribute_Rounding
or else Id
= Attribute_Truncation
;
8229 end Is_Inline_Floating_Point_Attribute
;