1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Exp_Atag
; use Exp_Atag
;
32 with Exp_Ch2
; use Exp_Ch2
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Dist
; use Exp_Dist
;
37 with Exp_Imgv
; use Exp_Imgv
;
38 with Exp_Pakd
; use Exp_Pakd
;
39 with Exp_Strm
; use Exp_Strm
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Freeze
; use Freeze
;
43 with Gnatvsn
; use Gnatvsn
;
44 with Itypes
; use Itypes
;
46 with Namet
; use Namet
;
47 with Nmake
; use Nmake
;
48 with Nlists
; use Nlists
;
50 with Restrict
; use Restrict
;
51 with Rident
; use Rident
;
52 with Rtsfind
; use Rtsfind
;
54 with Sem_Aux
; use Sem_Aux
;
55 with Sem_Ch6
; use Sem_Ch6
;
56 with Sem_Ch7
; use Sem_Ch7
;
57 with Sem_Ch8
; use Sem_Ch8
;
58 with Sem_Eval
; use Sem_Eval
;
59 with Sem_Res
; use Sem_Res
;
60 with Sem_Util
; use Sem_Util
;
61 with Sinfo
; use Sinfo
;
62 with Snames
; use Snames
;
63 with Stand
; use Stand
;
64 with Stringt
; use Stringt
;
65 with Tbuild
; use Tbuild
;
66 with Ttypes
; use Ttypes
;
67 with Uintp
; use Uintp
;
68 with Uname
; use Uname
;
69 with Validsw
; use Validsw
;
71 package body Exp_Attr
is
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Build_Array_VS_Func
79 Formal_Typ
: Entity_Id
;
80 Array_Typ
: Entity_Id
;
81 Comp_Typ
: Entity_Id
) return Entity_Id
;
82 -- Validate the components of an array type by means of a function. Return
83 -- the entity of the validation function. The parameters are as follows:
85 -- * Attr - the 'Valid_Scalars attribute for which the function is
88 -- * Formal_Typ - the type of the generated function's only formal
91 -- * Array_Typ - the array type whose components are to be validated
93 -- * Comp_Typ - the component type of the array
95 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
96 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
98 function Build_Record_VS_Func
100 Formal_Typ
: Entity_Id
;
101 Rec_Typ
: Entity_Id
) return Entity_Id
;
102 -- Validate the components, discriminants, and variants of a record type by
103 -- means of a function. Return the entity of the validation function. The
104 -- parameters are as follows:
106 -- * Attr - the 'Valid_Scalars attribute for which the function is
109 -- * Formal_Typ - the type of the generated function's only formal
112 -- * Rec_Typ - the record type whose internals are to be validated
114 procedure Compile_Stream_Body_In_Scope
119 -- The body for a stream subprogram may be generated outside of the scope
120 -- of the type. If the type is fully private, it may depend on the full
121 -- view of other types (e.g. indexes) that are currently private as well.
122 -- We install the declarations of the package in which the type is declared
123 -- before compiling the body in what is its proper environment. The Check
124 -- parameter indicates if checks are to be suppressed for the stream body.
125 -- We suppress checks for array/record reads, since the rule is that these
126 -- are like assignments, out of range values due to uninitialized storage,
127 -- or other invalid values do NOT cause a Constraint_Error to be raised.
128 -- If we are within an instance body all visibility has been established
129 -- already and there is no need to install the package.
131 -- This mechanism is now extended to the component types of the array type,
132 -- when the component type is not in scope and is private, to handle
133 -- properly the case when the full view has defaulted discriminants.
135 -- This special processing is ultimately caused by the fact that the
136 -- compiler lacks a well-defined phase when full views are visible
137 -- everywhere. Having such a separate pass would remove much of the
138 -- special-case code that shuffles partial and full views in the middle
139 -- of semantic analysis and expansion.
141 procedure Expand_Access_To_Protected_Op
145 -- An attribute reference to a protected subprogram is transformed into
146 -- a pair of pointers: one to the object, and one to the operations.
147 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
149 procedure Expand_Fpt_Attribute
154 -- This procedure expands a call to a floating-point attribute function.
155 -- N is the attribute reference node, and Args is a list of arguments to
156 -- be passed to the function call. Pkg identifies the package containing
157 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
158 -- have already been converted to the floating-point type for which Pkg was
159 -- instantiated. The Nam argument is the relevant attribute processing
160 -- routine to be called. This is the same as the attribute name, except in
161 -- the Unaligned_Valid case.
163 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
164 -- This procedure expands a call to a floating-point attribute function
165 -- that takes a single floating-point argument. The function to be called
166 -- is always the same as the attribute name.
168 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
169 -- This procedure expands a call to a floating-point attribute function
170 -- that takes one floating-point argument and one integer argument. The
171 -- function to be called is always the same as the attribute name.
173 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
174 -- This procedure expands a call to a floating-point attribute function
175 -- that takes two floating-point arguments. The function to be called
176 -- is always the same as the attribute name.
178 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
179 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
180 -- loop may be converted into a conditional block. See body for details.
182 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
183 -- Handle the expansion of attributes 'Max and 'Min, including expanding
184 -- then out if we are in Modify_Tree_For_C mode.
186 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
187 -- Handles expansion of Pred or Succ attributes for case of non-real
188 -- operand with overflow checking required.
190 procedure Expand_Update_Attribute
(N
: Node_Id
);
191 -- Handle the expansion of attribute Update
193 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
194 -- Used for Last, Last, and Length, when the prefix is an array type.
195 -- Obtains the corresponding index subtype.
197 procedure Find_Fat_Info
199 Fat_Type
: out Entity_Id
;
200 Fat_Pkg
: out RE_Id
);
201 -- Given a floating-point type T, identifies the package containing the
202 -- attributes for this type (returned in Fat_Pkg), and the corresponding
203 -- type for which this package was instantiated from Fat_Gen. Error if T
204 -- is not a floating-point type.
206 function Find_Stream_Subprogram
208 Nam
: TSS_Name_Type
) return Entity_Id
;
209 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
210 -- types, the corresponding primitive operation is looked up, else the
211 -- appropriate TSS from the type itself, or from its closest ancestor
212 -- defining it, is returned. In both cases, inheritance of representation
213 -- aspects is thus taken into account.
215 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
216 -- The stream functions need to examine the underlying representation of
217 -- composite types. In some cases T may be non-private but its base type
218 -- is, in which case the function returns the corresponding full view.
220 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
221 -- Given a type, find a corresponding stream convert pragma that applies to
222 -- the implementation base type of this type (Typ). If found, return the
223 -- pragma node, otherwise return Empty if no pragma is found.
225 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
226 -- Utility for array attributes, returns true on packed constrained
227 -- arrays, and on access to same.
229 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
230 -- Returns true iff the given node refers to an attribute call that
231 -- can be expanded directly by the back end and does not need front end
232 -- expansion. Typically used for rounding and truncation attributes that
233 -- appear directly inside a conversion to integer.
235 -------------------------
236 -- Build_Array_VS_Func --
237 -------------------------
239 function Build_Array_VS_Func
241 Formal_Typ
: Entity_Id
;
242 Array_Typ
: Entity_Id
;
243 Comp_Typ
: Entity_Id
) return Entity_Id
245 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
247 function Validate_Component
249 Indexes
: List_Id
) return Node_Id
;
250 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
251 -- the entity of the validation parameter. Return the check associated
252 -- with the component.
254 function Validate_Dimension
257 Indexes
: List_Id
) return Node_Id
;
258 -- Process dimension Dim of the array type. Obj_Id denotes the entity
259 -- of the validation parameter. Indexes is a list where each dimension
260 -- deposits its loop variable, which will later identify a component.
261 -- Return the loop associated with the current dimension.
263 ------------------------
264 -- Validate_Component --
265 ------------------------
267 function Validate_Component
269 Indexes
: List_Id
) return Node_Id
274 if Is_Scalar_Type
(Comp_Typ
) then
275 Attr_Nam
:= Name_Valid
;
277 Attr_Nam
:= Name_Valid_Scalars
;
281 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
286 Make_If_Statement
(Loc
,
290 Make_Attribute_Reference
(Loc
,
292 Make_Indexed_Component
(Loc
,
294 Unchecked_Convert_To
(Array_Typ
,
295 New_Occurrence_Of
(Obj_Id
, Loc
)),
296 Expressions
=> Indexes
),
297 Attribute_Name
=> Attr_Nam
)),
299 Then_Statements
=> New_List
(
300 Make_Simple_Return_Statement
(Loc
,
301 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
302 end Validate_Component
;
304 ------------------------
305 -- Validate_Dimension --
306 ------------------------
308 function Validate_Dimension
311 Indexes
: List_Id
) return Node_Id
316 -- Validate the component once all dimensions have produced their
319 if Dim
> Number_Dimensions
(Array_Typ
) then
320 return Validate_Component
(Obj_Id
, Indexes
);
322 -- Process the current dimension
326 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
));
328 Append_To
(Indexes
, New_Occurrence_Of
(Index
, Loc
));
331 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
332 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
333 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
341 Make_Implicit_Loop_Statement
(Attr
,
344 Make_Iteration_Scheme
(Loc
,
345 Loop_Parameter_Specification
=>
346 Make_Loop_Parameter_Specification
(Loc
,
347 Defining_Identifier
=> Index
,
348 Discrete_Subtype_Definition
=>
349 Make_Attribute_Reference
(Loc
,
351 Unchecked_Convert_To
(Array_Typ
,
352 New_Occurrence_Of
(Obj_Id
, Loc
)),
353 Attribute_Name
=> Name_Range
,
354 Expressions
=> New_List
(
355 Make_Integer_Literal
(Loc
, Dim
))))),
356 Statements
=> New_List
(
357 Validate_Dimension
(Obj_Id
, Dim
+ 1, Indexes
)));
359 end Validate_Dimension
;
363 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
364 Indexes
: constant List_Id
:= New_List
;
365 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
368 -- Start of processing for Build_Array_VS_Func
371 Stmts
:= New_List
(Validate_Dimension
(Obj_Id
, 1, Indexes
));
377 Make_Simple_Return_Statement
(Loc
,
378 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
381 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
386 Set_Ekind
(Func_Id
, E_Function
);
387 Set_Is_Internal
(Func_Id
);
388 Set_Is_Pure
(Func_Id
);
390 if not Debug_Generated_Code
then
391 Set_Debug_Info_Off
(Func_Id
);
395 Make_Subprogram_Body
(Loc
,
397 Make_Function_Specification
(Loc
,
398 Defining_Unit_Name
=> Func_Id
,
399 Parameter_Specifications
=> New_List
(
400 Make_Parameter_Specification
(Loc
,
401 Defining_Identifier
=> Obj_Id
,
403 Out_Present
=> False,
404 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
406 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
407 Declarations
=> New_List
,
408 Handled_Statement_Sequence
=>
409 Make_Handled_Sequence_Of_Statements
(Loc
,
410 Statements
=> Stmts
)));
413 end Build_Array_VS_Func
;
415 ---------------------------------
416 -- Build_Disp_Get_Task_Id_Call --
417 ---------------------------------
419 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
420 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
421 Typ
: constant Entity_Id
:= Etype
(Actual
);
422 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
426 -- _Disp_Get_Task_Id (Actual)
429 Make_Function_Call
(Loc
,
430 Name
=> New_Occurrence_Of
(Subp
, Loc
),
431 Parameter_Associations
=> New_List
(Actual
));
432 end Build_Disp_Get_Task_Id_Call
;
434 --------------------------
435 -- Build_Record_VS_Func --
436 --------------------------
438 function Build_Record_VS_Func
440 Formal_Typ
: Entity_Id
;
441 Rec_Typ
: Entity_Id
) return Entity_Id
443 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
444 -- It generates code only when there are components, discriminants,
445 -- or variant parts to validate.
447 -- NOTE: The routines within Build_Record_VS_Func are intentionally
448 -- unnested to avoid deep indentation of code.
450 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
452 procedure Validate_Component_List
455 Stmts
: in out List_Id
);
456 -- Process all components and variant parts of component list Comp_List.
457 -- Obj_Id denotes the entity of the validation parameter. All new code
458 -- is added to list Stmts.
460 procedure Validate_Field
463 Cond
: in out Node_Id
);
464 -- Process component declaration or discriminant specification Field.
465 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
466 -- an "or else" conditional expression which contains the new code (if
469 procedure Validate_Fields
472 Stmts
: in out List_Id
);
473 -- Process component declarations or discriminant specifications in list
474 -- Fields. Obj_Id denotes the entity of the validation parameter. All
475 -- new code is added to list Stmts.
477 procedure Validate_Variant
480 Alts
: in out List_Id
);
481 -- Process variant Var. Obj_Id denotes the entity of the validation
482 -- parameter. Alts denotes a list of case statement alternatives which
483 -- contains the new code (if any).
485 procedure Validate_Variant_Part
488 Stmts
: in out List_Id
);
489 -- Process variant part Var_Part. Obj_Id denotes the entity of the
490 -- validation parameter. All new code is added to list Stmts.
492 -----------------------------
493 -- Validate_Component_List --
494 -----------------------------
496 procedure Validate_Component_List
499 Stmts
: in out List_Id
)
501 Var_Part
: constant Node_Id
:= Variant_Part
(Comp_List
);
504 -- Validate all components
508 Fields
=> Component_Items
(Comp_List
),
511 -- Validate the variant part
513 if Present
(Var_Part
) then
514 Validate_Variant_Part
516 Var_Part
=> Var_Part
,
519 end Validate_Component_List
;
525 procedure Validate_Field
528 Cond
: in out Node_Id
)
530 Field_Id
: constant Entity_Id
:= Defining_Entity
(Field
);
531 Field_Nam
: constant Name_Id
:= Chars
(Field_Id
);
532 Field_Typ
: constant Entity_Id
:= Validated_View
(Etype
(Field_Id
));
536 -- Do not process internally-generated fields. Note that checking for
537 -- Comes_From_Source is not correct because this will eliminate the
538 -- components within the corresponding record of a protected type.
540 if Nam_In
(Field_Nam
, Name_uObject
,
546 -- Do not process fields without any scalar components
548 elsif not Scalar_Part_Present
(Field_Typ
) then
551 -- Otherwise the field needs to be validated. Use Make_Identifier
552 -- rather than New_Occurrence_Of to identify the field because the
553 -- wrong entity may be picked up when private types are involved.
556 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
559 if Is_Scalar_Type
(Field_Typ
) then
560 Attr_Nam
:= Name_Valid
;
562 Attr_Nam
:= Name_Valid_Scalars
;
565 Evolve_Or_Else
(Cond
,
568 Make_Attribute_Reference
(Loc
,
570 Make_Selected_Component
(Loc
,
572 Unchecked_Convert_To
(Rec_Typ
,
573 New_Occurrence_Of
(Obj_Id
, Loc
)),
574 Selector_Name
=> Make_Identifier
(Loc
, Field_Nam
)),
575 Attribute_Name
=> Attr_Nam
)));
579 ---------------------
580 -- Validate_Fields --
581 ---------------------
583 procedure Validate_Fields
586 Stmts
: in out List_Id
)
592 -- Assume that none of the fields are eligible for verification
596 -- Validate all fields
598 Field
:= First_Non_Pragma
(Fields
);
599 while Present
(Field
) loop
605 Next_Non_Pragma
(Field
);
609 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
610 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
615 if Present
(Cond
) then
616 Append_New_To
(Stmts
,
617 Make_Implicit_If_Statement
(Attr
,
619 Then_Statements
=> New_List
(
620 Make_Simple_Return_Statement
(Loc
,
621 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
625 ----------------------
626 -- Validate_Variant --
627 ----------------------
629 procedure Validate_Variant
632 Alts
: in out List_Id
)
637 -- Assume that none of the components and variants are eligible for
642 -- Validate componants
644 Validate_Component_List
646 Comp_List
=> Component_List
(Var
),
649 -- Generate a null statement in case none of the components were
650 -- verified because this will otherwise eliminate an alternative
651 -- from the variant case statement and render the generated code
655 Append_New_To
(Stmts
, Make_Null_Statement
(Loc
));
659 -- when Discrete_Choices =>
663 Make_Case_Statement_Alternative
(Loc
,
665 New_Copy_List_Tree
(Discrete_Choices
(Var
)),
666 Statements
=> Stmts
));
667 end Validate_Variant
;
669 ---------------------------
670 -- Validate_Variant_Part --
671 ---------------------------
673 procedure Validate_Variant_Part
676 Stmts
: in out List_Id
)
678 Vars
: constant List_Id
:= Variants
(Var_Part
);
683 -- Assume that none of the variants are eligible for verification
689 Var
:= First_Non_Pragma
(Vars
);
690 while Present
(Var
) loop
696 Next_Non_Pragma
(Var
);
699 -- Even though individual variants may lack eligible components, the
700 -- alternatives must still be generated.
702 pragma Assert
(Present
(Alts
));
705 -- case Rec_Typ (Obj_Id).Discriminant is
706 -- when Discrete_Choices_1 =>
708 -- when Discrete_Choices_N =>
712 Append_New_To
(Stmts
,
713 Make_Case_Statement
(Loc
,
715 Make_Selected_Component
(Loc
,
717 Unchecked_Convert_To
(Rec_Typ
,
718 New_Occurrence_Of
(Obj_Id
, Loc
)),
719 Selector_Name
=> New_Copy_Tree
(Name
(Var_Part
))),
720 Alternatives
=> Alts
));
721 end Validate_Variant_Part
;
725 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
726 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
734 -- Start of processing for Build_Record_VS_Func
739 -- Use the root type when dealing with a class-wide type
741 if Is_Class_Wide_Type
(Typ
) then
742 Typ
:= Root_Type
(Typ
);
745 Typ_Decl
:= Declaration_Node
(Typ
);
746 Typ_Def
:= Type_Definition
(Typ_Decl
);
748 -- The components of a derived type are located in the extension part
750 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
751 Typ_Ext
:= Record_Extension_Part
(Typ_Def
);
753 if Present
(Typ_Ext
) then
754 Comps
:= Component_List
(Typ_Ext
);
759 -- Otherwise the components are available in the definition
762 Comps
:= Component_List
(Typ_Def
);
765 -- The code generated by this routine is as follows:
767 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
769 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
770 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
775 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
776 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
781 -- case Discriminant_1 is
783 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
784 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
789 -- case Discriminant_N is
798 -- Assume that the record type lacks eligible components, discriminants,
799 -- and variant parts.
803 -- Validate the discriminants
805 if not Is_Unchecked_Union
(Rec_Typ
) then
808 Fields
=> Discriminant_Specifications
(Typ_Decl
),
812 -- Validate the components and variant parts
814 Validate_Component_List
822 Append_New_To
(Stmts
,
823 Make_Simple_Return_Statement
(Loc
,
824 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
827 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
832 Set_Ekind
(Func_Id
, E_Function
);
833 Set_Is_Internal
(Func_Id
);
834 Set_Is_Pure
(Func_Id
);
836 if not Debug_Generated_Code
then
837 Set_Debug_Info_Off
(Func_Id
);
841 Make_Subprogram_Body
(Loc
,
843 Make_Function_Specification
(Loc
,
844 Defining_Unit_Name
=> Func_Id
,
845 Parameter_Specifications
=> New_List
(
846 Make_Parameter_Specification
(Loc
,
847 Defining_Identifier
=> Obj_Id
,
848 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
850 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
851 Declarations
=> New_List
,
852 Handled_Statement_Sequence
=>
853 Make_Handled_Sequence_Of_Statements
(Loc
,
854 Statements
=> Stmts
)),
855 Suppress
=> Discriminant_Check
);
858 end Build_Record_VS_Func
;
860 ----------------------------------
861 -- Compile_Stream_Body_In_Scope --
862 ----------------------------------
864 procedure Compile_Stream_Body_In_Scope
870 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
871 Curr
: constant Entity_Id
:= Current_Scope
;
872 Install
: Boolean := False;
873 Scop
: Entity_Id
:= Scope
(Arr
);
877 and then not In_Open_Scopes
(Scop
)
878 and then Ekind
(Scop
) = E_Package
883 -- The component type may be private, in which case we install its
884 -- full view to compile the subprogram.
886 -- The component type may be private, in which case we install its
887 -- full view to compile the subprogram. We do not do this if the
888 -- type has a Stream_Convert pragma, which indicates that there are
889 -- special stream-processing operations for that type (for example
890 -- Unbounded_String and its wide varieties).
892 Scop
:= Scope
(C_Type
);
894 if Is_Private_Type
(C_Type
)
895 and then Present
(Full_View
(C_Type
))
896 and then not In_Open_Scopes
(Scop
)
897 and then Ekind
(Scop
) = E_Package
898 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
904 -- If we are within an instance body, then all visibility has been
905 -- established already and there is no need to install the package.
907 if Install
and then not In_Instance_Body
then
909 Install_Visible_Declarations
(Scop
);
910 Install_Private_Declarations
(Scop
);
912 -- The entities in the package are now visible, but the generated
913 -- stream entity must appear in the current scope (usually an
914 -- enclosing stream function) so that itypes all have their proper
923 Insert_Action
(N
, Decl
);
925 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
930 -- Remove extra copy of current scope, and package itself
933 End_Package_Scope
(Scop
);
935 end Compile_Stream_Body_In_Scope
;
937 -----------------------------------
938 -- Expand_Access_To_Protected_Op --
939 -----------------------------------
941 procedure Expand_Access_To_Protected_Op
946 -- The value of the attribute_reference is a record containing two
947 -- fields: an access to the protected object, and an access to the
948 -- subprogram itself. The prefix is a selected component.
950 Loc
: constant Source_Ptr
:= Sloc
(N
);
952 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
955 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
956 Acc
: constant Entity_Id
:=
957 Etype
(Next_Component
(First_Component
(E_T
)));
961 -- Start of processing for Expand_Access_To_Protected_Op
964 -- Within the body of the protected type, the prefix designates a local
965 -- operation, and the object is the first parameter of the corresponding
966 -- protected body of the current enclosing operation.
968 if Is_Entity_Name
(Pref
) then
969 -- All indirect calls are external calls, so must do locking and
970 -- barrier reevaluation, even if the 'Access occurs within the
971 -- protected body. Hence the call to External_Subprogram, as opposed
972 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
973 -- that indirect calls from within the same protected body will
974 -- deadlock, as allowed by RM-9.5.1(8,15,17).
976 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
978 -- Don't traverse the scopes when the attribute occurs within an init
979 -- proc, because we directly use the _init formal of the init proc in
982 Curr
:= Current_Scope
;
983 if not Is_Init_Proc
(Curr
) then
984 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
986 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
987 Curr
:= Scope
(Curr
);
991 -- In case of protected entries the first formal of its Protected_
992 -- Body_Subprogram is the address of the object.
994 if Ekind
(Curr
) = E_Entry
then
998 (Protected_Body_Subprogram
(Curr
)), Loc
);
1000 -- If the current scope is an init proc, then use the address of the
1001 -- _init formal as the object reference.
1003 elsif Is_Init_Proc
(Curr
) then
1005 Make_Attribute_Reference
(Loc
,
1006 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
1007 Attribute_Name
=> Name_Address
);
1009 -- In case of protected subprograms the first formal of its
1010 -- Protected_Body_Subprogram is the object and we get its address.
1014 Make_Attribute_Reference
(Loc
,
1018 (Protected_Body_Subprogram
(Curr
)), Loc
),
1019 Attribute_Name
=> Name_Address
);
1022 -- Case where the prefix is not an entity name. Find the
1023 -- version of the protected operation to be called from
1024 -- outside the protected object.
1029 (External_Subprogram
1030 (Entity
(Selector_Name
(Pref
))), Loc
);
1033 Make_Attribute_Reference
(Loc
,
1034 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1035 Attribute_Name
=> Name_Address
);
1039 Make_Attribute_Reference
(Loc
,
1041 Attribute_Name
=> Name_Access
);
1043 -- We set the type of the access reference to the already generated
1044 -- access_to_subprogram type, and declare the reference analyzed, to
1045 -- prevent further expansion when the enclosing aggregate is analyzed.
1047 Set_Etype
(Sub_Ref
, Acc
);
1048 Set_Analyzed
(Sub_Ref
);
1051 Make_Aggregate
(Loc
,
1052 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1054 -- Sub_Ref has been marked as analyzed, but we still need to make sure
1055 -- Sub is correctly frozen.
1057 Freeze_Before
(N
, Entity
(Sub
));
1060 Analyze_And_Resolve
(N
, E_T
);
1062 -- For subsequent analysis, the node must retain its type. The backend
1063 -- will replace it with the equivalent type where needed.
1066 end Expand_Access_To_Protected_Op
;
1068 --------------------------
1069 -- Expand_Fpt_Attribute --
1070 --------------------------
1072 procedure Expand_Fpt_Attribute
1078 Loc
: constant Source_Ptr
:= Sloc
(N
);
1079 Typ
: constant Entity_Id
:= Etype
(N
);
1083 -- The function name is the selected component Attr_xxx.yyy where
1084 -- Attr_xxx is the package name, and yyy is the argument Nam.
1086 -- Note: it would be more usual to have separate RE entries for each
1087 -- of the entities in the Fat packages, but first they have identical
1088 -- names (so we would have to have lots of renaming declarations to
1089 -- meet the normal RE rule of separate names for all runtime entities),
1090 -- and second there would be an awful lot of them.
1093 Make_Selected_Component
(Loc
,
1094 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
1095 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
1097 -- The generated call is given the provided set of parameters, and then
1098 -- wrapped in a conversion which converts the result to the target type
1099 -- We use the base type as the target because a range check may be
1103 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
1104 Make_Function_Call
(Loc
,
1106 Parameter_Associations
=> Args
)));
1108 Analyze_And_Resolve
(N
, Typ
);
1109 end Expand_Fpt_Attribute
;
1111 ----------------------------
1112 -- Expand_Fpt_Attribute_R --
1113 ----------------------------
1115 -- The single argument is converted to its root type to call the
1116 -- appropriate runtime function, with the actual call being built
1117 -- by Expand_Fpt_Attribute
1119 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
1120 E1
: constant Node_Id
:= First
(Expressions
(N
));
1124 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1125 Expand_Fpt_Attribute
1126 (N
, Pkg
, Attribute_Name
(N
),
1127 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
1128 end Expand_Fpt_Attribute_R
;
1130 -----------------------------
1131 -- Expand_Fpt_Attribute_RI --
1132 -----------------------------
1134 -- The first argument is converted to its root type and the second
1135 -- argument is converted to standard long long integer to call the
1136 -- appropriate runtime function, with the actual call being built
1137 -- by Expand_Fpt_Attribute
1139 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
1140 E1
: constant Node_Id
:= First
(Expressions
(N
));
1143 E2
: constant Node_Id
:= Next
(E1
);
1145 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1146 Expand_Fpt_Attribute
1147 (N
, Pkg
, Attribute_Name
(N
),
1149 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1150 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
1151 end Expand_Fpt_Attribute_RI
;
1153 -----------------------------
1154 -- Expand_Fpt_Attribute_RR --
1155 -----------------------------
1157 -- The two arguments are converted to their root types to call the
1158 -- appropriate runtime function, with the actual call being built
1159 -- by Expand_Fpt_Attribute
1161 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
1162 E1
: constant Node_Id
:= First
(Expressions
(N
));
1163 E2
: constant Node_Id
:= Next
(E1
);
1168 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1169 Expand_Fpt_Attribute
1170 (N
, Pkg
, Attribute_Name
(N
),
1172 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1173 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
1174 end Expand_Fpt_Attribute_RR
;
1176 ---------------------------------
1177 -- Expand_Loop_Entry_Attribute --
1178 ---------------------------------
1180 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
1181 procedure Build_Conditional_Block
1184 Loop_Stmt
: Node_Id
;
1185 If_Stmt
: out Node_Id
;
1186 Blk_Stmt
: out Node_Id
);
1187 -- Create a block Blk_Stmt with an empty declarative list and a single
1188 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1189 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1191 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
1192 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1195 -----------------------------
1196 -- Build_Conditional_Block --
1197 -----------------------------
1199 procedure Build_Conditional_Block
1202 Loop_Stmt
: Node_Id
;
1203 If_Stmt
: out Node_Id
;
1204 Blk_Stmt
: out Node_Id
)
1207 -- Do not reanalyze the original loop statement because it is simply
1210 Set_Analyzed
(Loop_Stmt
);
1213 Make_Block_Statement
(Loc
,
1214 Declarations
=> New_List
,
1215 Handled_Statement_Sequence
=>
1216 Make_Handled_Sequence_Of_Statements
(Loc
,
1217 Statements
=> New_List
(Loop_Stmt
)));
1219 if Present
(Cond
) then
1221 Make_If_Statement
(Loc
,
1223 Then_Statements
=> New_List
(Blk_Stmt
));
1227 end Build_Conditional_Block
;
1229 ------------------------
1230 -- Is_Array_Iteration --
1231 ------------------------
1233 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1234 Stmt
: constant Node_Id
:= Original_Node
(N
);
1238 if Nkind
(Stmt
) = N_Loop_Statement
1239 and then Present
(Iteration_Scheme
(Stmt
))
1240 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1242 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1245 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1249 end Is_Array_Iteration
;
1253 Pref
: constant Node_Id
:= Prefix
(N
);
1254 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1255 Exprs
: constant List_Id
:= Expressions
(N
);
1257 Blk
: Node_Id
:= Empty
;
1259 Installed
: Boolean;
1261 Loop_Id
: Entity_Id
;
1262 Loop_Stmt
: Node_Id
;
1263 Result
: Node_Id
:= Empty
;
1265 Temp_Decl
: Node_Id
;
1266 Temp_Id
: Entity_Id
;
1268 -- Start of processing for Expand_Loop_Entry_Attribute
1271 -- Step 1: Find the related loop
1273 -- The loop label variant of attribute 'Loop_Entry already has all the
1274 -- information in its expression.
1276 if Present
(Exprs
) then
1277 Loop_Id
:= Entity
(First
(Exprs
));
1278 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1280 -- Climb the parent chain to find the nearest enclosing loop. Skip
1281 -- all internally generated loops for quantified expressions and for
1282 -- element iterators over multidimensional arrays because the pragma
1283 -- applies to source loop.
1287 while Present
(Loop_Stmt
) loop
1288 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1289 and then Nkind
(Original_Node
(Loop_Stmt
)) = N_Loop_Statement
1290 and then Comes_From_Source
(Original_Node
(Loop_Stmt
))
1295 Loop_Stmt
:= Parent
(Loop_Stmt
);
1298 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1301 Loc
:= Sloc
(Loop_Stmt
);
1303 -- Step 2: Transform the loop
1305 -- The loop has already been transformed during the expansion of a prior
1306 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1308 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1310 -- When the related loop name appears as the argument of attribute
1311 -- Loop_Entry, the corresponding label construct is the generated
1312 -- block statement. This is because the expander reuses the label.
1314 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1315 Decls
:= Declarations
(Loop_Stmt
);
1317 -- In all other cases, the loop must appear in the handled sequence
1318 -- of statements of the generated block.
1322 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1324 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1326 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1329 -- Transform the loop into a conditional block
1332 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1333 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1335 -- Infinite loops are transformed into:
1338 -- Temp1 : constant <type of Pref1> := <Pref1>;
1340 -- TempN : constant <type of PrefN> := <PrefN>;
1343 -- <original source statements with attribute rewrites>
1348 Build_Conditional_Block
(Loc
,
1350 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1356 -- While loops are transformed into:
1358 -- function Fnn return Boolean is
1360 -- <condition actions>
1361 -- return <condition>;
1366 -- Temp1 : constant <type of Pref1> := <Pref1>;
1368 -- TempN : constant <type of PrefN> := <PrefN>;
1371 -- <original source statements with attribute rewrites>
1372 -- exit when not Fnn;
1377 -- Note that loops over iterators and containers are already
1378 -- converted into while loops.
1380 elsif Present
(Condition
(Scheme
)) then
1382 Func_Decl
: Node_Id
;
1383 Func_Id
: Entity_Id
;
1387 -- Wrap the condition of the while loop in a Boolean function.
1388 -- This avoids the duplication of the same code which may lead
1389 -- to gigi issues with respect to multiple declaration of the
1390 -- same entity in the presence of side effects or checks. Note
1391 -- that the condition actions must also be relocated to the
1392 -- wrapping function.
1395 -- <condition actions>
1396 -- return <condition>;
1398 if Present
(Condition_Actions
(Scheme
)) then
1399 Stmts
:= Condition_Actions
(Scheme
);
1405 Make_Simple_Return_Statement
(Loc
,
1406 Expression
=> Relocate_Node
(Condition
(Scheme
))));
1409 -- function Fnn return Boolean is
1414 Func_Id
:= Make_Temporary
(Loc
, 'F');
1416 Make_Subprogram_Body
(Loc
,
1418 Make_Function_Specification
(Loc
,
1419 Defining_Unit_Name
=> Func_Id
,
1420 Result_Definition
=>
1421 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1422 Declarations
=> Empty_List
,
1423 Handled_Statement_Sequence
=>
1424 Make_Handled_Sequence_Of_Statements
(Loc
,
1425 Statements
=> Stmts
));
1427 -- The function is inserted before the related loop. Make sure
1428 -- to analyze it in the context of the loop's enclosing scope.
1430 Push_Scope
(Scope
(Loop_Id
));
1431 Insert_Action
(Loop_Stmt
, Func_Decl
);
1434 -- Transform the original while loop into an infinite loop
1435 -- where the last statement checks the negated condition. This
1436 -- placement ensures that the condition will not be evaluated
1437 -- twice on the first iteration.
1439 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1443 -- exit when not Fnn;
1445 Append_To
(Statements
(Loop_Stmt
),
1446 Make_Exit_Statement
(Loc
,
1450 Make_Function_Call
(Loc
,
1451 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1453 Build_Conditional_Block
(Loc
,
1455 Make_Function_Call
(Loc
,
1456 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1457 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1462 -- Ada 2012 iteration over an array is transformed into:
1464 -- if <Array_Nam>'Length (1) > 0
1465 -- and then <Array_Nam>'Length (N) > 0
1468 -- Temp1 : constant <type of Pref1> := <Pref1>;
1470 -- TempN : constant <type of PrefN> := <PrefN>;
1472 -- for X in ... loop -- multiple loops depending on dims
1473 -- <original source statements with attribute rewrites>
1478 elsif Is_Array_Iteration
(Loop_Stmt
) then
1480 Array_Nam
: constant Entity_Id
:=
1481 Entity
(Name
(Iterator_Specification
1482 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1483 Num_Dims
: constant Pos
:=
1484 Number_Dimensions
(Etype
(Array_Nam
));
1485 Cond
: Node_Id
:= Empty
;
1489 -- Generate a check which determines whether all dimensions of
1490 -- the array are non-null.
1492 for Dim
in 1 .. Num_Dims
loop
1496 Make_Attribute_Reference
(Loc
,
1497 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1498 Attribute_Name
=> Name_Length
,
1499 Expressions
=> New_List
(
1500 Make_Integer_Literal
(Loc
, Dim
))),
1502 Make_Integer_Literal
(Loc
, 0));
1510 Right_Opnd
=> Check
);
1514 Build_Conditional_Block
(Loc
,
1516 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1521 -- For loops are transformed into:
1523 -- if <Low> <= <High> then
1525 -- Temp1 : constant <type of Pref1> := <Pref1>;
1527 -- TempN : constant <type of PrefN> := <PrefN>;
1529 -- for <Def_Id> in <Low> .. <High> loop
1530 -- <original source statements with attribute rewrites>
1535 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1537 Loop_Spec
: constant Node_Id
:=
1538 Loop_Parameter_Specification
(Scheme
);
1543 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1545 -- When the loop iterates over a subtype indication with a
1546 -- range, use the low and high bounds of the subtype itself.
1548 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1549 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1552 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1559 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1560 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1562 Build_Conditional_Block
(Loc
,
1564 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1570 Decls
:= Declarations
(Blk
);
1573 -- Step 3: Create a constant to capture the value of the prefix at the
1574 -- entry point into the loop.
1576 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1578 -- Preserve the tag of the prefix by offering a specific view of the
1579 -- class-wide version of the prefix.
1581 if Is_Tagged_Type
(Base_Typ
) then
1582 Tagged_Case
: declare
1583 CW_Temp
: Entity_Id
;
1588 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1590 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1591 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1594 Make_Object_Declaration
(Loc
,
1595 Defining_Identifier
=> CW_Temp
,
1596 Constant_Present
=> True,
1597 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1599 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1600 Append_To
(Decls
, Aux_Decl
);
1603 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1606 Make_Object_Renaming_Declaration
(Loc
,
1607 Defining_Identifier
=> Temp_Id
,
1608 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1610 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1611 Append_To
(Decls
, Temp_Decl
);
1617 Untagged_Case
: declare
1618 Temp_Expr
: Node_Id
;
1623 -- Generate a nominal type for the constant when the prefix is of
1624 -- a constrained type. This is achieved by setting the Etype of
1625 -- the relocated prefix to its base type. Since the prefix is now
1626 -- the initialization expression of the constant, its freezing
1627 -- will produce a proper nominal type.
1629 Temp_Expr
:= Relocate_Node
(Pref
);
1630 Set_Etype
(Temp_Expr
, Base_Typ
);
1633 -- Temp : constant Base_Typ := Pref;
1636 Make_Object_Declaration
(Loc
,
1637 Defining_Identifier
=> Temp_Id
,
1638 Constant_Present
=> True,
1639 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1640 Expression
=> Temp_Expr
);
1641 Append_To
(Decls
, Temp_Decl
);
1645 -- Step 4: Analyze all bits
1647 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1649 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1650 -- associated loop, ensure the proper visibility for analysis.
1652 if not Installed
then
1653 Push_Scope
(Scope
(Loop_Id
));
1656 -- The analysis of the conditional block takes care of the constant
1659 if Present
(Result
) then
1660 Rewrite
(Loop_Stmt
, Result
);
1661 Analyze
(Loop_Stmt
);
1663 -- The conditional block was analyzed when a previous 'Loop_Entry was
1664 -- expanded. There is no point in reanalyzing the block, simply analyze
1665 -- the declaration of the constant.
1668 if Present
(Aux_Decl
) then
1672 Analyze
(Temp_Decl
);
1675 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1678 if not Installed
then
1681 end Expand_Loop_Entry_Attribute
;
1683 ------------------------------
1684 -- Expand_Min_Max_Attribute --
1685 ------------------------------
1687 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1689 -- Min and Max are handled by the back end (except that static cases
1690 -- have already been evaluated during semantic processing, although the
1691 -- back end should not count on this). The one bit of special processing
1692 -- required in the normal case is that these two attributes typically
1693 -- generate conditionals in the code, so check the relevant restriction.
1695 Check_Restriction
(No_Implicit_Conditionals
, N
);
1697 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1699 if Modify_Tree_For_C
then
1701 Loc
: constant Source_Ptr
:= Sloc
(N
);
1702 Typ
: constant Entity_Id
:= Etype
(N
);
1703 Expr
: constant Node_Id
:= First
(Expressions
(N
));
1704 Left
: constant Node_Id
:= Relocate_Node
(Expr
);
1705 Right
: constant Node_Id
:= Relocate_Node
(Next
(Expr
));
1707 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
;
1708 -- Returns Left >= Right for Max, Left <= Right for Min
1714 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
is
1716 if Attribute_Name
(N
) = Name_Max
then
1720 Right_Opnd
=> Right
);
1725 Right_Opnd
=> Right
);
1729 -- Start of processing for Min_Max
1732 -- If both Left and Right are side effect free, then we can just
1733 -- use Duplicate_Expr to duplicate the references and return
1735 -- (if Left >=|<= Right then Left else Right)
1737 if Side_Effect_Free
(Left
) and then Side_Effect_Free
(Right
) then
1739 Make_If_Expression
(Loc
,
1740 Expressions
=> New_List
(
1741 Make_Compare
(Left
, Right
),
1742 Duplicate_Subexpr_No_Checks
(Left
),
1743 Duplicate_Subexpr_No_Checks
(Right
))));
1745 -- Otherwise we generate declarations to capture the values.
1747 -- The translation is
1750 -- T1 : constant typ := Left;
1751 -- T2 : constant typ := Right;
1753 -- (if T1 >=|<= T2 then T1 else T2)
1758 T1
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1759 T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Right
);
1763 Make_Expression_With_Actions
(Loc
,
1764 Actions
=> New_List
(
1765 Make_Object_Declaration
(Loc
,
1766 Defining_Identifier
=> T1
,
1767 Constant_Present
=> True,
1768 Object_Definition
=>
1769 New_Occurrence_Of
(Etype
(Left
), Loc
),
1770 Expression
=> Relocate_Node
(Left
)),
1772 Make_Object_Declaration
(Loc
,
1773 Defining_Identifier
=> T2
,
1774 Constant_Present
=> True,
1775 Object_Definition
=>
1776 New_Occurrence_Of
(Etype
(Right
), Loc
),
1777 Expression
=> Relocate_Node
(Right
))),
1780 Make_If_Expression
(Loc
,
1781 Expressions
=> New_List
(
1783 (New_Occurrence_Of
(T1
, Loc
),
1784 New_Occurrence_Of
(T2
, Loc
)),
1785 New_Occurrence_Of
(T1
, Loc
),
1786 New_Occurrence_Of
(T2
, Loc
)))));
1790 Analyze_And_Resolve
(N
, Typ
);
1793 end Expand_Min_Max_Attribute
;
1795 ----------------------------------
1796 -- Expand_N_Attribute_Reference --
1797 ----------------------------------
1799 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1800 Loc
: constant Source_Ptr
:= Sloc
(N
);
1801 Typ
: constant Entity_Id
:= Etype
(N
);
1802 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1803 Pref
: constant Node_Id
:= Prefix
(N
);
1804 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1805 Exprs
: constant List_Id
:= Expressions
(N
);
1806 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1808 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1809 -- Rewrites a stream attribute for Read, Write or Output with the
1810 -- procedure call. Pname is the entity for the procedure to call.
1812 ------------------------------
1813 -- Rewrite_Stream_Proc_Call --
1814 ------------------------------
1816 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1817 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1818 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1819 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1820 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1821 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1824 -- The expansion depends on Item, the second actual, which is
1825 -- the object being streamed in or out.
1827 -- If the item is a component of a packed array type, and
1828 -- a conversion is needed on exit, we introduce a temporary to
1829 -- hold the value, because otherwise the packed reference will
1830 -- not be properly expanded.
1832 if Nkind
(Item
) = N_Indexed_Component
1833 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1834 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1838 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1844 Make_Object_Declaration
(Loc
,
1845 Defining_Identifier
=> Temp
,
1846 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1847 Set_Etype
(Temp
, Formal_Typ
);
1850 Make_Assignment_Statement
(Loc
,
1851 Name
=> New_Copy_Tree
(Item
),
1853 Unchecked_Convert_To
1854 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1856 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1860 Make_Procedure_Call_Statement
(Loc
,
1861 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1862 Parameter_Associations
=> Exprs
),
1865 Rewrite
(N
, Make_Null_Statement
(Loc
));
1870 -- For the class-wide dispatching cases, and for cases in which
1871 -- the base type of the second argument matches the base type of
1872 -- the corresponding formal parameter (that is to say the stream
1873 -- operation is not inherited), we are all set, and can use the
1874 -- argument unchanged.
1876 if not Is_Class_Wide_Type
(Entity
(Pref
))
1877 and then not Is_Class_Wide_Type
(Etype
(Item
))
1878 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1880 -- Perform a view conversion when either the argument or the
1881 -- formal parameter are of a private type.
1883 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1884 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1887 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1889 -- Otherwise perform a regular type conversion to ensure that all
1890 -- relevant checks are installed.
1893 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1896 -- For untagged derived types set Assignment_OK, to prevent
1897 -- copies from being created when the unchecked conversion
1898 -- is expanded (which would happen in Remove_Side_Effects
1899 -- if Expand_N_Unchecked_Conversion were allowed to call
1900 -- Force_Evaluation). The copy could violate Ada semantics in
1901 -- cases such as an actual that is an out parameter. Note that
1902 -- this approach is also used in exp_ch7 for calls to controlled
1903 -- type operations to prevent problems with actuals wrapped in
1904 -- unchecked conversions.
1906 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1907 Set_Assignment_OK
(Item
);
1911 -- The stream operation to call may be a renaming created by an
1912 -- attribute definition clause, and may not be frozen yet. Ensure
1913 -- that it has the necessary extra formals.
1915 if not Is_Frozen
(Pname
) then
1916 Create_Extra_Formals
(Pname
);
1919 -- And now rewrite the call
1922 Make_Procedure_Call_Statement
(Loc
,
1923 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1924 Parameter_Associations
=> Exprs
));
1927 end Rewrite_Stream_Proc_Call
;
1929 -- Start of processing for Expand_N_Attribute_Reference
1932 -- Do required validity checking, if enabled. Do not apply check to
1933 -- output parameters of an Asm instruction, since the value of this
1934 -- is not set till after the attribute has been elaborated, and do
1935 -- not apply the check to the arguments of a 'Read or 'Input attribute
1936 -- reference since the scalar argument is an OUT scalar.
1938 if Validity_Checks_On
and then Validity_Check_Operands
1939 and then Id
/= Attribute_Asm_Output
1940 and then Id
/= Attribute_Read
1941 and then Id
/= Attribute_Input
1946 Expr
:= First
(Expressions
(N
));
1947 while Present
(Expr
) loop
1948 Ensure_Valid
(Expr
);
1954 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1955 -- place function, then a temporary return object needs to be created
1956 -- and access to it must be passed to the function.
1958 if Is_Build_In_Place_Function_Call
(Pref
) then
1960 -- If attribute is 'Old, the context is a postcondition, and
1961 -- the temporary must go in the corresponding subprogram, not
1962 -- the postcondition function or any created blocks, as when
1963 -- the attribute appears in a quantified expression. This is
1964 -- handled below in the expansion of the attribute.
1966 if Attribute_Name
(Parent
(Pref
)) = Name_Old
then
1969 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1972 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
1973 -- containing build-in-place function calls whose returned object covers
1976 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
1977 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
1980 -- If prefix is a protected type name, this is a reference to the
1981 -- current instance of the type. For a component definition, nothing
1982 -- to do (expansion will occur in the init proc). In other contexts,
1983 -- rewrite into reference to current instance.
1985 if Is_Protected_Self_Reference
(Pref
)
1987 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1988 N_Discriminant_Association
)
1989 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1990 N_Component_Definition
)
1992 -- No action needed for these attributes since the current instance
1993 -- will be rewritten to be the name of the _object parameter
1994 -- associated with the enclosing protected subprogram (see below).
1996 and then Id
/= Attribute_Access
1997 and then Id
/= Attribute_Unchecked_Access
1998 and then Id
/= Attribute_Unrestricted_Access
2000 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
2004 -- Remaining processing depends on specific attribute
2006 -- Note: individual sections of the following case statement are
2007 -- allowed to assume there is no code after the case statement, and
2008 -- are legitimately allowed to execute return statements if they have
2009 -- nothing more to do.
2013 -- Attributes related to Ada 2012 iterators
2015 when Attribute_Constant_Indexing
2016 | Attribute_Default_Iterator
2017 | Attribute_Implicit_Dereference
2018 | Attribute_Iterable
2019 | Attribute_Iterator_Element
2020 | Attribute_Variable_Indexing
2024 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2025 -- were already rejected by the parser. Thus they shouldn't appear here.
2027 when Internal_Attribute_Id
=>
2028 raise Program_Error
;
2034 when Attribute_Access
2035 | Attribute_Unchecked_Access
2036 | Attribute_Unrestricted_Access
2038 Access_Cases
: declare
2039 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
2040 Btyp_DDT
: Entity_Id
;
2042 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
2043 -- If N denotes a compound name (selected component, indexed
2044 -- component, or slice), returns the name of the outermost such
2045 -- enclosing object. Otherwise returns N. If the object is a
2046 -- renaming, then the renamed object is returned.
2048 ----------------------
2049 -- Enclosing_Object --
2050 ----------------------
2052 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
2057 while Nkind_In
(Obj_Name
, N_Selected_Component
,
2058 N_Indexed_Component
,
2061 Obj_Name
:= Prefix
(Obj_Name
);
2064 return Get_Referenced_Object
(Obj_Name
);
2065 end Enclosing_Object
;
2067 -- Local declarations
2069 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
2071 -- Start of processing for Access_Cases
2074 Btyp_DDT
:= Designated_Type
(Btyp
);
2076 -- Handle designated types that come from the limited view
2078 if From_Limited_With
(Btyp_DDT
)
2079 and then Has_Non_Limited_View
(Btyp_DDT
)
2081 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
2084 -- In order to improve the text of error messages, the designated
2085 -- type of access-to-subprogram itypes is set by the semantics as
2086 -- the associated subprogram entity (see sem_attr). Now we replace
2087 -- such node with the proper E_Subprogram_Type itype.
2089 if Id
= Attribute_Unrestricted_Access
2090 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
2092 -- The following conditions ensure that this special management
2093 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2094 -- At this stage other cases in which the designated type is
2095 -- still a subprogram (instead of an E_Subprogram_Type) are
2096 -- wrong because the semantics must have overridden the type of
2097 -- the node with the type imposed by the context.
2099 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
2100 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
2102 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
2106 Subp
: constant Entity_Id
:=
2107 Directly_Designated_Type
(Typ
);
2109 Extra
: Entity_Id
:= Empty
;
2110 New_Formal
: Entity_Id
;
2111 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
2112 Subp_Typ
: Entity_Id
;
2115 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
2116 Set_Etype
(Subp_Typ
, Etype
(Subp
));
2117 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
2119 if Present
(Old_Formal
) then
2120 New_Formal
:= New_Copy
(Old_Formal
);
2121 Set_First_Entity
(Subp_Typ
, New_Formal
);
2124 Set_Scope
(New_Formal
, Subp_Typ
);
2125 Etyp
:= Etype
(New_Formal
);
2127 -- Handle itypes. There is no need to duplicate
2128 -- here the itypes associated with record types
2129 -- (i.e the implicit full view of private types).
2132 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
2134 Extra
:= New_Copy
(Etyp
);
2135 Set_Parent
(Extra
, New_Formal
);
2136 Set_Etype
(New_Formal
, Extra
);
2137 Set_Scope
(Extra
, Subp_Typ
);
2140 Extra
:= New_Formal
;
2141 Next_Formal
(Old_Formal
);
2142 exit when No
(Old_Formal
);
2144 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
2145 Next_Entity
(New_Formal
);
2148 Unlink_Next_Entity
(New_Formal
);
2149 Set_Last_Entity
(Subp_Typ
, Extra
);
2152 -- Now that the explicit formals have been duplicated,
2153 -- any extra formals needed by the subprogram must be
2156 if Present
(Extra
) then
2157 Set_Extra_Formal
(Extra
, Empty
);
2160 Create_Extra_Formals
(Subp_Typ
);
2161 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
2166 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
2167 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
2169 -- If prefix is a type name, this is a reference to the current
2170 -- instance of the type, within its initialization procedure.
2172 elsif Is_Entity_Name
(Pref
)
2173 and then Is_Type
(Entity
(Pref
))
2180 -- If the current instance name denotes a task type, then
2181 -- the access attribute is rewritten to be the name of the
2182 -- "_task" parameter associated with the task type's task
2183 -- procedure. An unchecked conversion is applied to ensure
2184 -- a type match in cases of expander-generated calls (e.g.
2187 if Is_Task_Type
(Entity
(Pref
)) then
2189 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
2190 while Present
(Formal
) loop
2191 exit when Chars
(Formal
) = Name_uTask
;
2192 Next_Entity
(Formal
);
2195 pragma Assert
(Present
(Formal
));
2198 Unchecked_Convert_To
(Typ
,
2199 New_Occurrence_Of
(Formal
, Loc
)));
2202 elsif Is_Protected_Type
(Entity
(Pref
)) then
2204 -- No action needed for current instance located in a
2205 -- component definition (expansion will occur in the
2208 if Is_Protected_Type
(Current_Scope
) then
2211 -- If the current instance reference is located in a
2212 -- protected subprogram or entry then rewrite the access
2213 -- attribute to be the name of the "_object" parameter.
2214 -- An unchecked conversion is applied to ensure a type
2215 -- match in cases of expander-generated calls (e.g. init
2218 -- The code may be nested in a block, so find enclosing
2219 -- scope that is a protected operation.
2226 Subp
:= Current_Scope
;
2227 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
2228 Subp
:= Scope
(Subp
);
2233 (Protected_Body_Subprogram
(Subp
));
2235 -- For a protected subprogram the _Object parameter
2236 -- is the protected record, so we create an access
2237 -- to it. The _Object parameter of an entry is an
2240 if Ekind
(Subp
) = E_Entry
then
2242 Unchecked_Convert_To
(Typ
,
2243 New_Occurrence_Of
(Formal
, Loc
)));
2248 Unchecked_Convert_To
(Typ
,
2249 Make_Attribute_Reference
(Loc
,
2250 Attribute_Name
=> Name_Unrestricted_Access
,
2252 New_Occurrence_Of
(Formal
, Loc
))));
2253 Analyze_And_Resolve
(N
);
2258 -- The expression must appear in a default expression,
2259 -- (which in the initialization procedure is the right-hand
2260 -- side of an assignment), and not in a discriminant
2265 while Present
(Par
) loop
2266 exit when Nkind
(Par
) = N_Assignment_Statement
;
2268 if Nkind
(Par
) = N_Component_Declaration
then
2272 Par
:= Parent
(Par
);
2275 if Present
(Par
) then
2277 Make_Attribute_Reference
(Loc
,
2278 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2279 Attribute_Name
=> Attribute_Name
(N
)));
2281 Analyze_And_Resolve
(N
, Typ
);
2286 -- If the prefix of an Access attribute is a dereference of an
2287 -- access parameter (or a renaming of such a dereference, or a
2288 -- subcomponent of such a dereference) and the context is a
2289 -- general access type (including the type of an object or
2290 -- component with an access_definition, but not the anonymous
2291 -- type of an access parameter or access discriminant), then
2292 -- apply an accessibility check to the access parameter. We used
2293 -- to rewrite the access parameter as a type conversion, but that
2294 -- could only be done if the immediate prefix of the Access
2295 -- attribute was the dereference, and didn't handle cases where
2296 -- the attribute is applied to a subcomponent of the dereference,
2297 -- since there's generally no available, appropriate access type
2298 -- to convert to in that case. The attribute is passed as the
2299 -- point to insert the check, because the access parameter may
2300 -- come from a renaming, possibly in a different scope, and the
2301 -- check must be associated with the attribute itself.
2303 elsif Id
= Attribute_Access
2304 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2305 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2306 and then (Ekind
(Btyp
) = E_General_Access_Type
2307 or else Is_Local_Anonymous_Access
(Btyp
))
2308 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
2309 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2310 = E_Anonymous_Access_Type
2311 and then Present
(Extra_Accessibility
2312 (Entity
(Prefix
(Enc_Object
))))
2314 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2316 -- Ada 2005 (AI-251): If the designated type is an interface we
2317 -- add an implicit conversion to force the displacement of the
2318 -- pointer to reference the secondary dispatch table.
2320 elsif Is_Interface
(Btyp_DDT
)
2321 and then (Comes_From_Source
(N
)
2322 or else Comes_From_Source
(Ref_Object
)
2323 or else (Nkind
(Ref_Object
) in N_Has_Chars
2324 and then Chars
(Ref_Object
) = Name_uInit
))
2326 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2328 -- No implicit conversion required if types match, or if
2329 -- the prefix is the class_wide_type of the interface. In
2330 -- either case passing an object of the interface type has
2331 -- already set the pointer correctly.
2333 if Btyp_DDT
= Etype
(Ref_Object
)
2334 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2336 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2341 Rewrite
(Prefix
(N
),
2342 Convert_To
(Btyp_DDT
,
2343 New_Copy_Tree
(Prefix
(N
))));
2345 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2348 -- When the object is an explicit dereference, convert the
2349 -- dereference's prefix.
2353 Obj_DDT
: constant Entity_Id
:=
2355 (Directly_Designated_Type
2356 (Etype
(Prefix
(Ref_Object
))));
2358 -- No implicit conversion required if designated types
2361 if Obj_DDT
/= Btyp_DDT
2362 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2363 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2367 New_Copy_Tree
(Prefix
(Ref_Object
))));
2368 Analyze_And_Resolve
(N
, Typ
);
2379 -- Transforms 'Adjacent into a call to the floating-point attribute
2380 -- function Adjacent in Fat_xxx (where xxx is the root type)
2382 when Attribute_Adjacent
=>
2383 Expand_Fpt_Attribute_RR
(N
);
2389 when Attribute_Address
=> Address
: declare
2390 Task_Proc
: Entity_Id
;
2393 -- If the prefix is a task or a task type, the useful address is that
2394 -- of the procedure for the task body, i.e. the actual program unit.
2395 -- We replace the original entity with that of the procedure.
2397 if Is_Entity_Name
(Pref
)
2398 and then Is_Task_Type
(Entity
(Pref
))
2400 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2402 while Present
(Task_Proc
) loop
2403 exit when Ekind
(Task_Proc
) = E_Procedure
2404 and then Etype
(First_Formal
(Task_Proc
)) =
2405 Corresponding_Record_Type
(Ptyp
);
2406 Next_Entity
(Task_Proc
);
2409 if Present
(Task_Proc
) then
2410 Set_Entity
(Pref
, Task_Proc
);
2411 Set_Etype
(Pref
, Etype
(Task_Proc
));
2414 -- Similarly, the address of a protected operation is the address
2415 -- of the corresponding protected body, regardless of the protected
2416 -- object from which it is selected.
2418 elsif Nkind
(Pref
) = N_Selected_Component
2419 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2420 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2424 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2426 elsif Nkind
(Pref
) = N_Explicit_Dereference
2427 and then Ekind
(Ptyp
) = E_Subprogram_Type
2428 and then Convention
(Ptyp
) = Convention_Protected
2430 -- The prefix is be a dereference of an access_to_protected_
2431 -- subprogram. The desired address is the second component of
2432 -- the record that represents the access.
2435 Addr
: constant Entity_Id
:= Etype
(N
);
2436 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2437 T
: constant Entity_Id
:=
2438 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2442 Unchecked_Convert_To
(Addr
,
2443 Make_Selected_Component
(Loc
,
2444 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2445 Selector_Name
=> New_Occurrence_Of
(
2446 Next_Entity
(First_Entity
(T
)), Loc
))));
2448 Analyze_And_Resolve
(N
, Addr
);
2451 -- Ada 2005 (AI-251): Class-wide interface objects are always
2452 -- "displaced" to reference the tag associated with the interface
2453 -- type. In order to obtain the real address of such objects we
2454 -- generate a call to a run-time subprogram that returns the base
2455 -- address of the object.
2457 -- This processing is not needed in the VM case, where dispatching
2458 -- issues are taken care of by the virtual machine.
2460 elsif Is_Class_Wide_Type
(Ptyp
)
2461 and then Is_Interface
(Underlying_Type
(Ptyp
))
2462 and then Tagged_Type_Expansion
2463 and then not (Nkind
(Pref
) in N_Has_Entity
2464 and then Is_Subprogram
(Entity
(Pref
)))
2467 Make_Function_Call
(Loc
,
2468 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2469 Parameter_Associations
=> New_List
(
2470 Relocate_Node
(N
))));
2475 -- Deal with packed array reference, other cases are handled by
2478 if Involves_Packed_Array_Reference
(Pref
) then
2479 Expand_Packed_Address_Reference
(N
);
2487 when Attribute_Alignment
=> Alignment
: declare
2491 -- For class-wide types, X'Class'Alignment is transformed into a
2492 -- direct reference to the Alignment of the class type, so that the
2493 -- back end does not have to deal with the X'Class'Alignment
2496 if Is_Entity_Name
(Pref
)
2497 and then Is_Class_Wide_Type
(Entity
(Pref
))
2499 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2502 -- For x'Alignment applied to an object of a class wide type,
2503 -- transform X'Alignment into a call to the predefined primitive
2504 -- operation _Alignment applied to X.
2506 elsif Is_Class_Wide_Type
(Ptyp
) then
2508 Make_Attribute_Reference
(Loc
,
2510 Attribute_Name
=> Name_Tag
);
2512 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2514 -- Case where the context is a specific integer type with which
2515 -- the original attribute was compatible. The function has a
2516 -- specific type as well, so to preserve the compatibility we
2517 -- must convert explicitly.
2519 if Typ
/= Standard_Integer
then
2520 New_Node
:= Convert_To
(Typ
, New_Node
);
2523 Rewrite
(N
, New_Node
);
2524 Analyze_And_Resolve
(N
, Typ
);
2527 -- For all other cases, we just have to deal with the case of
2528 -- the fact that the result can be universal.
2531 Apply_Universal_Integer_Attribute_Checks
(N
);
2539 -- We compute this if a packed array reference was present, otherwise we
2540 -- leave the computation up to the back end.
2542 when Attribute_Bit
=>
2543 if Involves_Packed_Array_Reference
(Pref
) then
2544 Expand_Packed_Bit_Reference
(N
);
2546 Apply_Universal_Integer_Attribute_Checks
(N
);
2553 -- We compute this if a component clause was present, otherwise we leave
2554 -- the computation up to the back end, since we don't know what layout
2557 -- Note that the attribute can apply to a naked record component
2558 -- in generated code (i.e. the prefix is an identifier that
2559 -- references the component or discriminant entity).
2561 when Attribute_Bit_Position
=> Bit_Position
: declare
2565 if Nkind
(Pref
) = N_Identifier
then
2566 CE
:= Entity
(Pref
);
2568 CE
:= Entity
(Selector_Name
(Pref
));
2571 if Known_Static_Component_Bit_Offset
(CE
) then
2573 Make_Integer_Literal
(Loc
,
2574 Intval
=> Component_Bit_Offset
(CE
)));
2575 Analyze_And_Resolve
(N
, Typ
);
2578 Apply_Universal_Integer_Attribute_Checks
(N
);
2586 -- A reference to P'Body_Version or P'Version is expanded to
2589 -- pragma Import (C, Vnn, "uuuuT");
2591 -- Get_Version_String (Vnn)
2593 -- where uuuu is the unit name (dots replaced by double underscore)
2594 -- and T is B for the cases of Body_Version, or Version applied to a
2595 -- subprogram acting as its own spec, and S for Version applied to a
2596 -- subprogram spec or package. This sequence of code references the
2597 -- unsigned constant created in the main program by the binder.
2599 -- A special exception occurs for Standard, where the string returned
2600 -- is a copy of the library string in gnatvsn.ads.
2602 when Attribute_Body_Version
2606 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2611 -- If not library unit, get to containing library unit
2613 Pent
:= Entity
(Pref
);
2614 while Pent
/= Standard_Standard
2615 and then Scope
(Pent
) /= Standard_Standard
2616 and then not Is_Child_Unit
(Pent
)
2618 Pent
:= Scope
(Pent
);
2621 -- Special case Standard and Standard.ASCII
2623 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2625 Make_String_Literal
(Loc
,
2626 Strval
=> Verbose_Library_Version
));
2631 -- Build required string constant
2633 Get_Name_String
(Get_Unit_Name
(Pent
));
2636 for J
in 1 .. Name_Len
- 2 loop
2637 if Name_Buffer
(J
) = '.' then
2638 Store_String_Chars
("__");
2640 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2644 -- Case of subprogram acting as its own spec, always use body
2646 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2647 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2649 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2651 Store_String_Chars
("B");
2653 -- Case of no body present, always use spec
2655 elsif not Unit_Requires_Body
(Pent
) then
2656 Store_String_Chars
("S");
2658 -- Otherwise use B for Body_Version, S for spec
2660 elsif Id
= Attribute_Body_Version
then
2661 Store_String_Chars
("B");
2663 Store_String_Chars
("S");
2667 Lib
.Version_Referenced
(S
);
2669 -- Insert the object declaration
2671 Insert_Actions
(N
, New_List
(
2672 Make_Object_Declaration
(Loc
,
2673 Defining_Identifier
=> E
,
2674 Object_Definition
=>
2675 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2677 -- Set entity as imported with correct external name
2679 Set_Is_Imported
(E
);
2680 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2682 -- Set entity as internal to ensure proper Sprint output of its
2683 -- implicit importation.
2685 Set_Is_Internal
(E
);
2687 -- And now rewrite original reference
2690 Make_Function_Call
(Loc
,
2692 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2693 Parameter_Associations
=> New_List
(
2694 New_Occurrence_Of
(E
, Loc
))));
2697 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2704 -- Transforms 'Ceiling into a call to the floating-point attribute
2705 -- function Ceiling in Fat_xxx (where xxx is the root type)
2707 when Attribute_Ceiling
=>
2708 Expand_Fpt_Attribute_R
(N
);
2714 -- Transforms 'Callable attribute into a call to the Callable function
2716 when Attribute_Callable
=>
2718 -- We have an object of a task interface class-wide type as a prefix
2719 -- to Callable. Generate:
2720 -- callable (Task_Id (Pref._disp_get_task_id));
2722 if Ada_Version
>= Ada_2005
2723 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2724 and then Is_Interface
(Ptyp
)
2725 and then Is_Task_Interface
(Ptyp
)
2728 Make_Function_Call
(Loc
,
2730 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2731 Parameter_Associations
=> New_List
(
2732 Make_Unchecked_Type_Conversion
(Loc
,
2734 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2735 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
2738 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2741 Analyze_And_Resolve
(N
, Standard_Boolean
);
2747 -- Transforms 'Caller attribute into a call to either the
2748 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2750 when Attribute_Caller
=> Caller
: declare
2751 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2752 Ent
: constant Entity_Id
:= Entity
(Pref
);
2753 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2754 Nest_Depth
: Integer := 0;
2761 if Is_Protected_Type
(Conctype
) then
2762 case Corresponding_Runtime_Package
(Conctype
) is
2763 when System_Tasking_Protected_Objects_Entries
=>
2766 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2768 when System_Tasking_Protected_Objects_Single_Entry
=>
2771 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2774 raise Program_Error
;
2778 Unchecked_Convert_To
(Id_Kind
,
2779 Make_Function_Call
(Loc
,
2781 Parameter_Associations
=> New_List
(
2783 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2788 -- Determine the nesting depth of the E'Caller attribute, that
2789 -- is, how many accept statements are nested within the accept
2790 -- statement for E at the point of E'Caller. The runtime uses
2791 -- this depth to find the specified entry call.
2793 for J
in reverse 0 .. Scope_Stack
.Last
loop
2794 S
:= Scope_Stack
.Table
(J
).Entity
;
2796 -- We should not reach the scope of the entry, as it should
2797 -- already have been checked in Sem_Attr that this attribute
2798 -- reference is within a matching accept statement.
2800 pragma Assert
(S
/= Conctype
);
2805 elsif Is_Entry
(S
) then
2806 Nest_Depth
:= Nest_Depth
+ 1;
2811 Unchecked_Convert_To
(Id_Kind
,
2812 Make_Function_Call
(Loc
,
2814 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2815 Parameter_Associations
=> New_List
(
2816 Make_Integer_Literal
(Loc
,
2817 Intval
=> Int
(Nest_Depth
))))));
2820 Analyze_And_Resolve
(N
, Id_Kind
);
2827 -- Transforms 'Compose into a call to the floating-point attribute
2828 -- function Compose in Fat_xxx (where xxx is the root type)
2830 -- Note: we strictly should have special code here to deal with the
2831 -- case of absurdly negative arguments (less than Integer'First)
2832 -- which will return a (signed) zero value, but it hardly seems
2833 -- worth the effort. Absurdly large positive arguments will raise
2834 -- constraint error which is fine.
2836 when Attribute_Compose
=>
2837 Expand_Fpt_Attribute_RI
(N
);
2843 when Attribute_Constrained
=> Constrained
: declare
2844 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2846 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2847 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2848 -- view of an aliased object whose subtype is constrained.
2850 ---------------------------------
2851 -- Is_Constrained_Aliased_View --
2852 ---------------------------------
2854 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2858 if Is_Entity_Name
(Obj
) then
2861 if Present
(Renamed_Object
(E
)) then
2862 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2864 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2868 return Is_Aliased_View
(Obj
)
2870 (Is_Constrained
(Etype
(Obj
))
2872 (Nkind
(Obj
) = N_Explicit_Dereference
2874 not Object_Type_Has_Constrained_Partial_View
2875 (Typ
=> Base_Type
(Etype
(Obj
)),
2876 Scop
=> Current_Scope
)));
2878 end Is_Constrained_Aliased_View
;
2880 -- Start of processing for Constrained
2883 -- Reference to a parameter where the value is passed as an extra
2884 -- actual, corresponding to the extra formal referenced by the
2885 -- Extra_Constrained field of the corresponding formal. If this
2886 -- is an entry in-parameter, it is replaced by a constant renaming
2887 -- for which Extra_Constrained is never created.
2889 if Present
(Formal_Ent
)
2890 and then Ekind
(Formal_Ent
) /= E_Constant
2891 and then Present
(Extra_Constrained
(Formal_Ent
))
2895 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2897 -- If the prefix is an access to object, the attribute applies to
2898 -- the designated object, so rewrite with an explicit dereference.
2900 elsif Is_Access_Type
(Etype
(Pref
))
2902 (not Is_Entity_Name
(Pref
) or else Is_Object
(Entity
(Pref
)))
2905 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Pref
)));
2906 Analyze_And_Resolve
(N
, Standard_Boolean
);
2909 -- For variables with a Extra_Constrained field, we use the
2910 -- corresponding entity.
2912 elsif Nkind
(Pref
) = N_Identifier
2913 and then Ekind
(Entity
(Pref
)) = E_Variable
2914 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2918 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2920 -- For all other entity names, we can tell at compile time
2922 elsif Is_Entity_Name
(Pref
) then
2924 Ent
: constant Entity_Id
:= Entity
(Pref
);
2928 -- (RM J.4) obsolescent cases
2930 if Is_Type
(Ent
) then
2934 if Is_Private_Type
(Ent
) then
2935 Res
:= not Has_Discriminants
(Ent
)
2936 or else Is_Constrained
(Ent
);
2938 -- It not a private type, must be a generic actual type
2939 -- that corresponded to a private type. We know that this
2940 -- correspondence holds, since otherwise the reference
2941 -- within the generic template would have been illegal.
2944 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2945 Res
:= Is_Constrained
(Ent
);
2952 -- For access type, apply access check as needed
2954 if Is_Access_Type
(Ptyp
) then
2955 Apply_Access_Check
(N
);
2958 -- If the prefix is not a variable or is aliased, then
2959 -- definitely true; if it's a formal parameter without an
2960 -- associated extra formal, then treat it as constrained.
2962 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2963 -- constrained in order to set the attribute to True.
2965 if not Is_Variable
(Pref
)
2966 or else Present
(Formal_Ent
)
2967 or else (Ada_Version
< Ada_2005
2968 and then Is_Aliased_View
(Pref
))
2969 or else (Ada_Version
>= Ada_2005
2970 and then Is_Constrained_Aliased_View
(Pref
))
2974 -- Variable case, look at type to see if it is constrained.
2975 -- Note that the one case where this is not accurate (the
2976 -- procedure formal case), has been handled above.
2978 -- We use the Underlying_Type here (and below) in case the
2979 -- type is private without discriminants, but the full type
2980 -- has discriminants. This case is illegal, but we generate
2981 -- it internally for passing to the Extra_Constrained
2985 -- In Ada 2012, test for case of a limited tagged type,
2986 -- in which case the attribute is always required to
2987 -- return True. The underlying type is tested, to make
2988 -- sure we also return True for cases where there is an
2989 -- unconstrained object with an untagged limited partial
2990 -- view which has defaulted discriminants (such objects
2991 -- always produce a False in earlier versions of
2992 -- Ada). (Ada 2012: AI05-0214)
2995 Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2997 (Ada_Version
>= Ada_2012
2998 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2999 and then Is_Limited_Type
(Ptyp
));
3003 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Res
), Loc
));
3006 -- Prefix is not an entity name. These are also cases where we can
3007 -- always tell at compile time by looking at the form and type of the
3008 -- prefix. If an explicit dereference of an object with constrained
3009 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
3010 -- underlying type is a limited tagged type, then Constrained is
3011 -- required to always return True (Ada 2012: AI05-0214).
3017 not Is_Variable
(Pref
)
3019 (Nkind
(Pref
) = N_Explicit_Dereference
3021 not Object_Type_Has_Constrained_Partial_View
3022 (Typ
=> Base_Type
(Ptyp
),
3023 Scop
=> Current_Scope
))
3024 or else Is_Constrained
(Underlying_Type
(Ptyp
))
3025 or else (Ada_Version
>= Ada_2012
3026 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
3027 and then Is_Limited_Type
(Ptyp
))),
3031 Analyze_And_Resolve
(N
, Standard_Boolean
);
3038 -- Transforms 'Copy_Sign into a call to the floating-point attribute
3039 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
3041 when Attribute_Copy_Sign
=>
3042 Expand_Fpt_Attribute_RR
(N
);
3048 -- Transforms 'Count attribute into a call to the Count function
3050 when Attribute_Count
=> Count
: declare
3052 Conctyp
: Entity_Id
;
3054 Entry_Id
: Entity_Id
;
3059 -- If the prefix is a member of an entry family, retrieve both
3060 -- entry name and index. For a simple entry there is no index.
3062 if Nkind
(Pref
) = N_Indexed_Component
then
3063 Entnam
:= Prefix
(Pref
);
3064 Index
:= First
(Expressions
(Pref
));
3070 Entry_Id
:= Entity
(Entnam
);
3072 -- Find the concurrent type in which this attribute is referenced
3073 -- (there had better be one).
3075 Conctyp
:= Current_Scope
;
3076 while not Is_Concurrent_Type
(Conctyp
) loop
3077 Conctyp
:= Scope
(Conctyp
);
3082 if Is_Protected_Type
(Conctyp
) then
3084 -- No need to transform 'Count into a function call if the current
3085 -- scope has been eliminated. In this case such transformation is
3086 -- also not viable because the enclosing protected object is not
3089 if Is_Eliminated
(Current_Scope
) then
3093 case Corresponding_Runtime_Package
(Conctyp
) is
3094 when System_Tasking_Protected_Objects_Entries
=>
3095 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
3098 Make_Function_Call
(Loc
,
3100 Parameter_Associations
=> New_List
(
3102 (Find_Protection_Object
(Current_Scope
), Loc
),
3103 Entry_Index_Expression
3104 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
3106 when System_Tasking_Protected_Objects_Single_Entry
=>
3108 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
3111 Make_Function_Call
(Loc
,
3113 Parameter_Associations
=> New_List
(
3115 (Find_Protection_Object
(Current_Scope
), Loc
)));
3118 raise Program_Error
;
3125 Make_Function_Call
(Loc
,
3126 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
3127 Parameter_Associations
=> New_List
(
3128 Entry_Index_Expression
(Loc
,
3129 Entry_Id
, Index
, Scope
(Entry_Id
))));
3132 -- The call returns type Natural but the context is universal integer
3133 -- so any integer type is allowed. The attribute was already resolved
3134 -- so its Etype is the required result type. If the base type of the
3135 -- context type is other than Standard.Integer we put in a conversion
3136 -- to the required type. This can be a normal typed conversion since
3137 -- both input and output types of the conversion are integer types
3139 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
3140 Rewrite
(N
, Convert_To
(Typ
, Call
));
3145 Analyze_And_Resolve
(N
, Typ
);
3148 ---------------------
3149 -- Descriptor_Size --
3150 ---------------------
3152 when Attribute_Descriptor_Size
=>
3154 -- Attribute Descriptor_Size is handled by the back end when applied
3155 -- to an unconstrained array type.
3157 if Is_Array_Type
(Ptyp
)
3158 and then not Is_Constrained
(Ptyp
)
3160 Apply_Universal_Integer_Attribute_Checks
(N
);
3162 -- For any other type, the descriptor size is 0 because there is no
3163 -- actual descriptor, but the result is not formally static.
3166 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3168 Set_Is_Static_Expression
(N
, False);
3175 -- This processing is shared by Elab_Spec
3177 -- What we do is to insert the following declarations
3180 -- pragma Import (C, enn, "name___elabb/s");
3182 -- and then the Elab_Body/Spec attribute is replaced by a reference
3183 -- to this defining identifier.
3185 when Attribute_Elab_Body
3186 | Attribute_Elab_Spec
3188 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3189 -- back-end knows how to handle these attributes directly.
3191 if CodePeer_Mode
then
3196 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
3200 procedure Make_Elab_String
(Nod
: Node_Id
);
3201 -- Given Nod, an identifier, or a selected component, put the
3202 -- image into the current string literal, with double underline
3203 -- between components.
3205 ----------------------
3206 -- Make_Elab_String --
3207 ----------------------
3209 procedure Make_Elab_String
(Nod
: Node_Id
) is
3211 if Nkind
(Nod
) = N_Selected_Component
then
3212 Make_Elab_String
(Prefix
(Nod
));
3213 Store_String_Char
('_');
3214 Store_String_Char
('_');
3215 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
3218 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
3219 Get_Name_String
(Chars
(Nod
));
3222 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3223 end Make_Elab_String
;
3225 -- Start of processing for Elab_Body/Elab_Spec
3228 -- First we need to prepare the string literal for the name of
3229 -- the elaboration routine to be referenced.
3232 Make_Elab_String
(Pref
);
3233 Store_String_Chars
("___elab");
3234 Lang
:= Make_Identifier
(Loc
, Name_C
);
3236 if Id
= Attribute_Elab_Body
then
3237 Store_String_Char
('b');
3239 Store_String_Char
('s');
3244 Insert_Actions
(N
, New_List
(
3245 Make_Subprogram_Declaration
(Loc
,
3247 Make_Procedure_Specification
(Loc
,
3248 Defining_Unit_Name
=> Ent
)),
3251 Chars
=> Name_Import
,
3252 Pragma_Argument_Associations
=> New_List
(
3253 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3255 Make_Pragma_Argument_Association
(Loc
,
3256 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3258 Make_Pragma_Argument_Association
(Loc
,
3259 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3261 Set_Entity
(N
, Ent
);
3262 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3265 --------------------
3266 -- Elab_Subp_Body --
3267 --------------------
3269 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3270 -- this attribute directly, and if we are not in CodePeer mode it is
3271 -- entirely ignored ???
3273 when Attribute_Elab_Subp_Body
=>
3280 -- Elaborated is always True for preelaborated units, predefined units,
3281 -- pure units and units which have Elaborate_Body pragmas. These units
3282 -- have no elaboration entity.
3284 -- Note: The Elaborated attribute is never passed to the back end
3286 when Attribute_Elaborated
=> Elaborated
: declare
3287 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3290 if Present
(Elab_Id
) then
3293 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3294 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3296 Analyze_And_Resolve
(N
, Typ
);
3298 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3306 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3310 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3313 if Is_Non_Empty_List
(Exprs
) then
3314 Expr
:= First
(Exprs
);
3319 -- If the expression is an enumeration literal, it is replaced by the
3322 if Nkind
(Expr
) in N_Has_Entity
3323 and then Ekind
(Entity
(Expr
)) = E_Enumeration_Literal
3326 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Expr
))));
3328 -- If this is a renaming of a literal, recover the representation
3329 -- of the original. If it renames an expression there is nothing to
3332 elsif Nkind
(Expr
) in N_Has_Entity
3333 and then Ekind
(Entity
(Expr
)) = E_Constant
3334 and then Present
(Renamed_Object
(Entity
(Expr
)))
3335 and then Is_Entity_Name
(Renamed_Object
(Entity
(Expr
)))
3336 and then Ekind
(Entity
(Renamed_Object
(Entity
(Expr
)))) =
3337 E_Enumeration_Literal
3340 Make_Integer_Literal
(Loc
,
3341 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Expr
))))));
3343 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3344 -- X'Enum_Rep expands to
3348 -- This is simply a direct conversion from the enumeration type to
3349 -- the target integer type, which is treated by the back end as a
3350 -- normal integer conversion, treating the enumeration type as an
3351 -- integer, which is exactly what we want. We set Conversion_OK to
3352 -- make sure that the analyzer does not complain about what otherwise
3353 -- might be an illegal conversion.
3356 Rewrite
(N
, OK_Convert_To
(Typ
, Relocate_Node
(Expr
)));
3360 Analyze_And_Resolve
(N
, Typ
);
3367 when Attribute_Enum_Val
=> Enum_Val
: declare
3369 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3372 -- X'Enum_Val (Y) expands to
3374 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3377 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3380 Make_Raise_Constraint_Error
(Loc
,
3384 Make_Function_Call
(Loc
,
3386 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3387 Parameter_Associations
=> New_List
(
3388 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3389 New_Occurrence_Of
(Standard_False
, Loc
))),
3391 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3392 Reason
=> CE_Range_Check_Failed
));
3395 Analyze_And_Resolve
(N
, Ptyp
);
3402 -- Transforms 'Exponent into a call to the floating-point attribute
3403 -- function Exponent in Fat_xxx (where xxx is the root type)
3405 when Attribute_Exponent
=>
3406 Expand_Fpt_Attribute_R
(N
);
3412 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3414 when Attribute_External_Tag
=>
3416 Make_Function_Call
(Loc
,
3418 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3419 Parameter_Associations
=> New_List
(
3420 Make_Attribute_Reference
(Loc
,
3421 Attribute_Name
=> Name_Tag
,
3422 Prefix
=> Prefix
(N
)))));
3424 Analyze_And_Resolve
(N
, Standard_String
);
3426 -----------------------
3427 -- Finalization_Size --
3428 -----------------------
3430 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3431 function Calculate_Header_Size
return Node_Id
;
3432 -- Generate a runtime call to calculate the size of the hidden header
3433 -- along with any added padding which would precede a heap-allocated
3434 -- object of the prefix type.
3436 ---------------------------
3437 -- Calculate_Header_Size --
3438 ---------------------------
3440 function Calculate_Header_Size
return Node_Id
is
3443 -- Universal_Integer
3444 -- (Header_Size_With_Padding (Pref'Alignment))
3447 Convert_To
(Universal_Integer
,
3448 Make_Function_Call
(Loc
,
3450 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3452 Parameter_Associations
=> New_List
(
3453 Make_Attribute_Reference
(Loc
,
3454 Prefix
=> New_Copy_Tree
(Pref
),
3455 Attribute_Name
=> Name_Alignment
))));
3456 end Calculate_Header_Size
;
3462 -- Start of Finalization_Size
3465 -- An object of a class-wide type first requires a runtime check to
3466 -- determine whether it is actually controlled or not. Depending on
3467 -- the outcome of this check, the Finalization_Size of the object
3468 -- may be zero or some positive value.
3470 -- In this scenario, Pref'Finalization_Size is expanded into
3472 -- Size : Integer := 0;
3474 -- if Needs_Finalization (Pref'Tag) then
3476 -- Universal_Integer
3477 -- (Header_Size_With_Padding (Pref'Alignment));
3480 -- and the attribute reference is replaced with a reference to Size.
3482 if Is_Class_Wide_Type
(Ptyp
) then
3483 Size
:= Make_Temporary
(Loc
, 'S');
3485 Insert_Actions
(N
, New_List
(
3488 -- Size : Integer := 0;
3490 Make_Object_Declaration
(Loc
,
3491 Defining_Identifier
=> Size
,
3492 Object_Definition
=>
3493 New_Occurrence_Of
(Standard_Integer
, Loc
),
3494 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3497 -- if Needs_Finalization (Pref'Tag) then
3499 -- Universal_Integer
3500 -- (Header_Size_With_Padding (Pref'Alignment));
3503 Make_If_Statement
(Loc
,
3505 Make_Function_Call
(Loc
,
3507 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3509 Parameter_Associations
=> New_List
(
3510 Make_Attribute_Reference
(Loc
,
3511 Prefix
=> New_Copy_Tree
(Pref
),
3512 Attribute_Name
=> Name_Tag
))),
3514 Then_Statements
=> New_List
(
3515 Make_Assignment_Statement
(Loc
,
3516 Name
=> New_Occurrence_Of
(Size
, Loc
),
3517 Expression
=> Calculate_Header_Size
)))));
3519 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3521 -- The prefix is known to be controlled at compile time. Calculate
3522 -- Finalization_Size by calling function Header_Size_With_Padding.
3524 elsif Needs_Finalization
(Ptyp
) then
3525 Rewrite
(N
, Calculate_Header_Size
);
3527 -- The prefix is not an object with controlled parts, so its
3528 -- Finalization_Size is zero.
3531 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3534 -- Due to cases where the entity type of the attribute is already
3535 -- resolved the rewritten N must get re-resolved to its appropriate
3538 Analyze_And_Resolve
(N
, Typ
);
3539 end Finalization_Size
;
3545 when Attribute_First
=>
3547 -- If the prefix type is a constrained packed array type which
3548 -- already has a Packed_Array_Impl_Type representation defined, then
3549 -- replace this attribute with a direct reference to 'First of the
3550 -- appropriate index subtype (since otherwise the back end will try
3551 -- to give us the value of 'First for this implementation type).
3553 if Is_Constrained_Packed_Array
(Ptyp
) then
3555 Make_Attribute_Reference
(Loc
,
3556 Attribute_Name
=> Name_First
,
3558 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3559 Analyze_And_Resolve
(N
, Typ
);
3561 -- For access type, apply access check as needed
3563 elsif Is_Access_Type
(Ptyp
) then
3564 Apply_Access_Check
(N
);
3566 -- For scalar type, if low bound is a reference to an entity, just
3567 -- replace with a direct reference. Note that we can only have a
3568 -- reference to a constant entity at this stage, anything else would
3569 -- have already been rewritten.
3571 elsif Is_Scalar_Type
(Ptyp
) then
3573 Lo
: constant Node_Id
:= Type_Low_Bound
(Ptyp
);
3575 if Is_Entity_Name
(Lo
) then
3576 Rewrite
(N
, New_Occurrence_Of
(Entity
(Lo
), Loc
));
3585 -- Compute this if component clause was present, otherwise we leave the
3586 -- computation to be completed in the back-end, since we don't know what
3587 -- layout will be chosen.
3589 when Attribute_First_Bit
=> First_Bit_Attr
: declare
3590 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3593 -- In Ada 2005 (or later) if we have the non-default bit order, then
3594 -- we return the original value as given in the component clause
3595 -- (RM 2005 13.5.2(3/2)).
3597 if Present
(Component_Clause
(CE
))
3598 and then Ada_Version
>= Ada_2005
3599 and then Reverse_Bit_Order
(Scope
(CE
))
3602 Make_Integer_Literal
(Loc
,
3603 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
3604 Analyze_And_Resolve
(N
, Typ
);
3606 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3607 -- rewrite with normalized value if we know it statically.
3609 elsif Known_Static_Component_Bit_Offset
(CE
) then
3611 Make_Integer_Literal
(Loc
,
3612 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
3613 Analyze_And_Resolve
(N
, Typ
);
3615 -- Otherwise left to back end, just do universal integer checks
3618 Apply_Universal_Integer_Attribute_Checks
(N
);
3622 --------------------------------
3623 -- Fixed_Value, Integer_Value --
3624 --------------------------------
3628 -- fixtype'Fixed_Value (integer-value)
3629 -- inttype'Fixed_Value (fixed-value)
3633 -- fixtype (integer-value)
3634 -- inttype (fixed-value)
3638 -- We do all the required analysis of the conversion here, because we do
3639 -- not want this to go through the fixed-point conversion circuits. Note
3640 -- that the back end always treats fixed-point as equivalent to the
3641 -- corresponding integer type anyway.
3642 -- However, in order to remove the handling of Do_Range_Check from the
3643 -- backend, we force the generation of a check on the result by
3644 -- setting the result type appropriately. Apply_Conversion_Checks
3645 -- will generate the required expansion.
3647 when Attribute_Fixed_Value
3648 | Attribute_Integer_Value
3651 Make_Type_Conversion
(Loc
,
3652 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3653 Expression
=> Relocate_Node
(First
(Exprs
))));
3655 -- Indicate that the result of the conversion may require a
3656 -- range check (see below);
3658 Set_Etype
(N
, Base_Type
(Entity
(Pref
)));
3661 -- Note: it might appear that a properly analyzed unchecked
3662 -- conversion would be just fine here, but that's not the case,
3663 -- since the full range checks performed by the following code
3665 -- Given that Fixed-point conversions are not further expanded
3666 -- to prevent the involvement of real type operations we have to
3667 -- construct two checks explicitly: one on the operand, and one
3668 -- on the result. This used to be done in part in the back-end,
3669 -- but for other targets (E.g. LLVM) it is preferable to create
3670 -- the tests in full in the front-end.
3672 if Is_Fixed_Point_Type
(Etype
(N
)) then
3674 Loc
: constant Source_Ptr
:= Sloc
(N
);
3675 Equiv_T
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', N
);
3676 Expr
: constant Node_Id
:= Expression
(N
);
3677 Fst
: constant Entity_Id
:= Root_Type
(Etype
(N
));
3682 Make_Full_Type_Declaration
(Sloc
(N
),
3683 Defining_Identifier
=> Equiv_T
,
3685 Make_Signed_Integer_Type_Definition
(Loc
,
3687 Make_Integer_Literal
(Loc
,
3689 Corresponding_Integer_Value
3690 (Type_Low_Bound
(Fst
))),
3692 Make_Integer_Literal
(Loc
,
3694 Corresponding_Integer_Value
3695 (Type_High_Bound
(Fst
)))));
3696 Insert_Action
(N
, Decl
);
3698 -- Verify that the conversion is possible
3700 Generate_Range_Check
(Expr
, Equiv_T
, CE_Overflow_Check_Failed
);
3702 -- and verify that the result is in range
3704 Generate_Range_Check
(N
, Etype
(N
), CE_Range_Check_Failed
);
3712 -- Transforms 'Floor into a call to the floating-point attribute
3713 -- function Floor in Fat_xxx (where xxx is the root type)
3715 when Attribute_Floor
=>
3716 Expand_Fpt_Attribute_R
(N
);
3722 -- For the fixed-point type Typ:
3728 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3729 -- Universal_Real (Type'Last))
3731 -- Note that we know that the type is a non-static subtype, or Fore
3732 -- would have itself been computed dynamically in Eval_Attribute.
3734 when Attribute_Fore
=>
3737 Make_Function_Call
(Loc
,
3739 New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
3741 Parameter_Associations
=> New_List
(
3742 Convert_To
(Universal_Real
,
3743 Make_Attribute_Reference
(Loc
,
3744 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3745 Attribute_Name
=> Name_First
)),
3747 Convert_To
(Universal_Real
,
3748 Make_Attribute_Reference
(Loc
,
3749 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3750 Attribute_Name
=> Name_Last
))))));
3752 Analyze_And_Resolve
(N
, Typ
);
3758 -- Transforms 'Fraction into a call to the floating-point attribute
3759 -- function Fraction in Fat_xxx (where xxx is the root type)
3761 when Attribute_Fraction
=>
3762 Expand_Fpt_Attribute_R
(N
);
3768 when Attribute_From_Any
=> From_Any
: declare
3769 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3770 Decls
: constant List_Id
:= New_List
;
3774 Build_From_Any_Call
(P_Type
,
3775 Relocate_Node
(First
(Exprs
)),
3777 Insert_Actions
(N
, Decls
);
3778 Analyze_And_Resolve
(N
, P_Type
);
3781 ----------------------
3782 -- Has_Same_Storage --
3783 ----------------------
3785 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3786 Loc
: constant Source_Ptr
:= Sloc
(N
);
3788 X
: constant Node_Id
:= Prefix
(N
);
3789 Y
: constant Node_Id
:= First
(Expressions
(N
));
3794 -- Rhe expressions for their addresses
3798 -- Rhe expressions for their sizes
3801 -- The attribute is expanded as:
3803 -- (X'address = Y'address)
3804 -- and then (X'Size = Y'Size)
3806 -- If both arguments have the same Etype the second conjunct can be
3810 Make_Attribute_Reference
(Loc
,
3811 Attribute_Name
=> Name_Address
,
3812 Prefix
=> New_Copy_Tree
(X
));
3815 Make_Attribute_Reference
(Loc
,
3816 Attribute_Name
=> Name_Address
,
3817 Prefix
=> New_Copy_Tree
(Y
));
3820 Make_Attribute_Reference
(Loc
,
3821 Attribute_Name
=> Name_Size
,
3822 Prefix
=> New_Copy_Tree
(X
));
3825 Make_Attribute_Reference
(Loc
,
3826 Attribute_Name
=> Name_Size
,
3827 Prefix
=> New_Copy_Tree
(Y
));
3829 if Etype
(X
) = Etype
(Y
) then
3832 Left_Opnd
=> X_Addr
,
3833 Right_Opnd
=> Y_Addr
));
3839 Left_Opnd
=> X_Addr
,
3840 Right_Opnd
=> Y_Addr
),
3843 Left_Opnd
=> X_Size
,
3844 Right_Opnd
=> Y_Size
)));
3847 Analyze_And_Resolve
(N
, Standard_Boolean
);
3848 end Has_Same_Storage
;
3854 -- For an exception returns a reference to the exception data:
3855 -- Exception_Id!(Prefix'Reference)
3857 -- For a task it returns a reference to the _task_id component of
3858 -- corresponding record:
3860 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3862 -- in Ada.Task_Identification
3864 when Attribute_Identity
=> Identity
: declare
3865 Id_Kind
: Entity_Id
;
3868 if Ptyp
= Standard_Exception_Type
then
3869 Id_Kind
:= RTE
(RE_Exception_Id
);
3871 if Present
(Renamed_Object
(Entity
(Pref
))) then
3872 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3876 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3878 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3880 -- If the prefix is a task interface, the Task_Id is obtained
3881 -- dynamically through a dispatching call, as for other task
3882 -- attributes applied to interfaces.
3884 if Ada_Version
>= Ada_2005
3885 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3886 and then Is_Interface
(Ptyp
)
3887 and then Is_Task_Interface
(Ptyp
)
3890 Unchecked_Convert_To
3891 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
3895 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3899 Analyze_And_Resolve
(N
, Id_Kind
);
3906 -- Image attribute is handled in separate unit Exp_Imgv
3908 when Attribute_Image
=>
3910 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3911 -- back-end knows how to handle this attribute directly.
3913 if CodePeer_Mode
then
3917 Expand_Image_Attribute
(N
);
3923 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3925 when Attribute_Img
=>
3926 Expand_Image_Attribute
(N
);
3932 when Attribute_Input
=> Input
: declare
3933 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3934 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3935 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3936 Strm
: constant Node_Id
:= First
(Exprs
);
3944 Cntrl
: Node_Id
:= Empty
;
3945 -- Value for controlling argument in call. Always Empty except in
3946 -- the dispatching (class-wide type) case, where it is a reference
3947 -- to the dummy object initialized to the right internal tag.
3949 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3950 -- The expansion of the attribute reference may generate a call to
3951 -- a user-defined stream subprogram that is frozen by the call. This
3952 -- can lead to access-before-elaboration problem if the reference
3953 -- appears in an object declaration and the subprogram body has not
3954 -- been seen. The freezing of the subprogram requires special code
3955 -- because it appears in an expanded context where expressions do
3956 -- not freeze their constituents.
3958 ------------------------------
3959 -- Freeze_Stream_Subprogram --
3960 ------------------------------
3962 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3963 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3967 -- If this is user-defined subprogram, the corresponding
3968 -- stream function appears as a renaming-as-body, and the
3969 -- user subprogram must be retrieved by tree traversal.
3972 and then Nkind
(Decl
) = N_Subprogram_Declaration
3973 and then Present
(Corresponding_Body
(Decl
))
3975 Bod
:= Corresponding_Body
(Decl
);
3977 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3978 N_Subprogram_Renaming_Declaration
3980 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3983 end Freeze_Stream_Subprogram
;
3985 -- Start of processing for Input
3988 -- If no underlying type, we have an error that will be diagnosed
3989 -- elsewhere, so here we just completely ignore the expansion.
3995 -- Stream operations can appear in user code even if the restriction
3996 -- No_Streams is active (for example, when instantiating a predefined
3997 -- container). In that case rewrite the attribute as a Raise to
3998 -- prevent any run-time use.
4000 if Restriction_Active
(No_Streams
) then
4002 Make_Raise_Program_Error
(Sloc
(N
),
4003 Reason
=> PE_Stream_Operation_Not_Allowed
));
4004 Set_Etype
(N
, B_Type
);
4008 -- If there is a TSS for Input, just call it
4010 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
4012 if Present
(Fname
) then
4016 -- If there is a Stream_Convert pragma, use it, we rewrite
4018 -- sourcetyp'Input (stream)
4022 -- sourcetyp (streamread (strmtyp'Input (stream)));
4024 -- where streamread is the given Read function that converts an
4025 -- argument of type strmtyp to type sourcetyp or a type from which
4026 -- it is derived (extra conversion required for the derived case).
4028 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4030 if Present
(Prag
) then
4031 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4032 Rfunc
:= Entity
(Expression
(Arg2
));
4036 Make_Function_Call
(Loc
,
4037 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4038 Parameter_Associations
=> New_List
(
4039 Make_Attribute_Reference
(Loc
,
4042 (Etype
(First_Formal
(Rfunc
)), Loc
),
4043 Attribute_Name
=> Name_Input
,
4044 Expressions
=> Exprs
)))));
4046 Analyze_And_Resolve
(N
, B_Type
);
4051 elsif Is_Elementary_Type
(U_Type
) then
4053 -- A special case arises if we have a defined _Read routine,
4054 -- since in this case we are required to call this routine.
4057 Typ
: Entity_Id
:= P_Type
;
4059 if Present
(Full_View
(Typ
)) then
4060 Typ
:= Full_View
(Typ
);
4063 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Read
)) then
4064 Build_Record_Or_Elementary_Input_Function
4065 (Loc
, Typ
, Decl
, Fname
, Use_Underlying
=> False);
4066 Insert_Action
(N
, Decl
);
4068 -- For normal cases, we call the I_xxx routine directly
4071 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
4072 Analyze_And_Resolve
(N
, P_Type
);
4079 elsif Is_Array_Type
(U_Type
) then
4080 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
4081 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4083 -- Dispatching case with class-wide type
4085 elsif Is_Class_Wide_Type
(P_Type
) then
4087 -- No need to do anything else compiling under restriction
4088 -- No_Dispatching_Calls. During the semantic analysis we
4089 -- already notified such violation.
4091 if Restriction_Active
(No_Dispatching_Calls
) then
4096 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
4100 -- Read the internal tag (RM 13.13.2(34)) and use it to
4101 -- initialize a dummy tag value. We used to generate:
4103 -- Descendant_Tag (String'Input (Strm), P_Type);
4105 -- which turns into a call to String_Input_Blk_IO. However,
4106 -- if the input is malformed, that could try to read an
4107 -- enormous String, causing chaos. So instead we call
4108 -- String_Input_Tag, which does the same thing as
4109 -- String_Input_Blk_IO, except that if the String is
4110 -- absurdly long, it raises an exception.
4112 -- This value is used only to provide a controlling
4113 -- argument for the eventual _Input call. Descendant_Tag is
4114 -- called rather than Internal_Tag to ensure that we have a
4115 -- tag for a type that is descended from the prefix type and
4116 -- declared at the same accessibility level (the exception
4117 -- Tag_Error will be raised otherwise). The level check is
4118 -- required for Ada 2005 because tagged types can be
4119 -- extended in nested scopes (AI-344).
4121 -- Note: we used to generate an explicit declaration of a
4122 -- constant Ada.Tags.Tag object, and use an occurrence of
4123 -- this constant in Cntrl, but this caused a secondary stack
4127 Make_Function_Call
(Loc
,
4129 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
4130 Parameter_Associations
=> New_List
(
4131 Make_Function_Call
(Loc
,
4134 (RTE
(RE_String_Input_Tag
), Loc
),
4135 Parameter_Associations
=> New_List
(
4136 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
4138 Make_Attribute_Reference
(Loc
,
4139 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
4140 Attribute_Name
=> Name_Tag
)));
4142 Set_Etype
(Expr
, RTE
(RE_Tag
));
4144 -- Now we need to get the entity for the call, and construct
4145 -- a function call node, where we preset a reference to Dnn
4146 -- as the controlling argument (doing an unchecked convert
4147 -- to the class-wide tagged type to make it look like a real
4150 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
4151 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
4152 Set_Etype
(Cntrl
, P_Type
);
4153 Set_Parent
(Cntrl
, N
);
4156 -- For tagged types, use the primitive Input function
4158 elsif Is_Tagged_Type
(U_Type
) then
4159 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
4161 -- All other record type cases, including protected records. The
4162 -- latter only arise for expander generated code for handling
4163 -- shared passive partition access.
4167 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4169 -- Ada 2005 (AI-216): Program_Error is raised executing default
4170 -- implementation of the Input attribute of an unchecked union
4171 -- type if the type lacks default discriminant values.
4173 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4174 and then No
(Discriminant_Constraint
(U_Type
))
4177 Make_Raise_Program_Error
(Loc
,
4178 Reason
=> PE_Unchecked_Union_Restriction
));
4183 -- Build the type's Input function, passing the subtype rather
4184 -- than its base type, because checks are needed in the case of
4185 -- constrained discriminants (see Ada 2012 AI05-0192).
4187 Build_Record_Or_Elementary_Input_Function
4188 (Loc
, U_Type
, Decl
, Fname
);
4189 Insert_Action
(N
, Decl
);
4191 if Nkind
(Parent
(N
)) = N_Object_Declaration
4192 and then Is_Record_Type
(U_Type
)
4194 -- The stream function may contain calls to user-defined
4195 -- Read procedures for individual components.
4202 Comp
:= First_Component
(U_Type
);
4203 while Present
(Comp
) loop
4205 Find_Stream_Subprogram
4206 (Etype
(Comp
), TSS_Stream_Read
);
4208 if Present
(Func
) then
4209 Freeze_Stream_Subprogram
(Func
);
4212 Next_Component
(Comp
);
4219 -- If we fall through, Fname is the function to be called. The result
4220 -- is obtained by calling the appropriate function, then converting
4221 -- the result. The conversion does a subtype check.
4224 Make_Function_Call
(Loc
,
4225 Name
=> New_Occurrence_Of
(Fname
, Loc
),
4226 Parameter_Associations
=> New_List
(
4227 Relocate_Node
(Strm
)));
4229 Set_Controlling_Argument
(Call
, Cntrl
);
4230 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
4231 Analyze_And_Resolve
(N
, P_Type
);
4233 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4234 Freeze_Stream_Subprogram
(Fname
);
4242 when Attribute_Invalid_Value
=>
4243 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
4249 when Attribute_Last
=>
4251 -- If the prefix type is a constrained packed array type which
4252 -- already has a Packed_Array_Impl_Type representation defined, then
4253 -- replace this attribute with a direct reference to 'Last of the
4254 -- appropriate index subtype (since otherwise the back end will try
4255 -- to give us the value of 'Last for this implementation type).
4257 if Is_Constrained_Packed_Array
(Ptyp
) then
4259 Make_Attribute_Reference
(Loc
,
4260 Attribute_Name
=> Name_Last
,
4261 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
4262 Analyze_And_Resolve
(N
, Typ
);
4264 -- For access type, apply access check as needed
4266 elsif Is_Access_Type
(Ptyp
) then
4267 Apply_Access_Check
(N
);
4269 -- For scalar type, if low bound is a reference to an entity, just
4270 -- replace with a direct reference. Note that we can only have a
4271 -- reference to a constant entity at this stage, anything else would
4272 -- have already been rewritten.
4274 elsif Is_Scalar_Type
(Ptyp
) then
4276 Hi
: constant Node_Id
:= Type_High_Bound
(Ptyp
);
4278 if Is_Entity_Name
(Hi
) then
4279 Rewrite
(N
, New_Occurrence_Of
(Entity
(Hi
), Loc
));
4288 -- We compute this if a component clause was present, otherwise we leave
4289 -- the computation up to the back end, since we don't know what layout
4292 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
4293 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4296 -- In Ada 2005 (or later) if we have the non-default bit order, then
4297 -- we return the original value as given in the component clause
4298 -- (RM 2005 13.5.2(3/2)).
4300 if Present
(Component_Clause
(CE
))
4301 and then Ada_Version
>= Ada_2005
4302 and then Reverse_Bit_Order
(Scope
(CE
))
4305 Make_Integer_Literal
(Loc
,
4306 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
4307 Analyze_And_Resolve
(N
, Typ
);
4309 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4310 -- rewrite with normalized value if we know it statically.
4312 elsif Known_Static_Component_Bit_Offset
(CE
)
4313 and then Known_Static_Esize
(CE
)
4316 Make_Integer_Literal
(Loc
,
4317 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
4319 Analyze_And_Resolve
(N
, Typ
);
4321 -- Otherwise leave to back end, just apply universal integer checks
4324 Apply_Universal_Integer_Attribute_Checks
(N
);
4332 -- Transforms 'Leading_Part into a call to the floating-point attribute
4333 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4335 -- Note: strictly, we should generate special case code to deal with
4336 -- absurdly large positive arguments (greater than Integer'Last), which
4337 -- result in returning the first argument unchanged, but it hardly seems
4338 -- worth the effort. We raise constraint error for absurdly negative
4339 -- arguments which is fine.
4341 when Attribute_Leading_Part
=>
4342 Expand_Fpt_Attribute_RI
(N
);
4348 when Attribute_Length
=> Length
: declare
4353 -- Processing for packed array types
4355 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
4356 Ityp
:= Get_Index_Subtype
(N
);
4358 -- If the index type, Ityp, is an enumeration type with holes,
4359 -- then we calculate X'Length explicitly using
4362 -- (0, Ityp'Pos (X'Last (N)) -
4363 -- Ityp'Pos (X'First (N)) + 1);
4365 -- Since the bounds in the template are the representation values
4366 -- and the back end would get the wrong value.
4368 if Is_Enumeration_Type
(Ityp
)
4369 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4374 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4378 Make_Attribute_Reference
(Loc
,
4379 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4380 Attribute_Name
=> Name_Max
,
4381 Expressions
=> New_List
4382 (Make_Integer_Literal
(Loc
, 0),
4386 Make_Op_Subtract
(Loc
,
4388 Make_Attribute_Reference
(Loc
,
4389 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4390 Attribute_Name
=> Name_Pos
,
4392 Expressions
=> New_List
(
4393 Make_Attribute_Reference
(Loc
,
4394 Prefix
=> Duplicate_Subexpr
(Pref
),
4395 Attribute_Name
=> Name_Last
,
4396 Expressions
=> New_List
(
4397 Make_Integer_Literal
(Loc
, Xnum
))))),
4400 Make_Attribute_Reference
(Loc
,
4401 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4402 Attribute_Name
=> Name_Pos
,
4404 Expressions
=> New_List
(
4405 Make_Attribute_Reference
(Loc
,
4407 Duplicate_Subexpr_No_Checks
(Pref
),
4408 Attribute_Name
=> Name_First
,
4409 Expressions
=> New_List
(
4410 Make_Integer_Literal
(Loc
, Xnum
)))))),
4412 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4414 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4417 -- If the prefix type is a constrained packed array type which
4418 -- already has a Packed_Array_Impl_Type representation defined,
4419 -- then replace this attribute with a reference to 'Range_Length
4420 -- of the appropriate index subtype (since otherwise the
4421 -- back end will try to give us the value of 'Length for
4422 -- this implementation type).s
4424 elsif Is_Constrained
(Ptyp
) then
4426 Make_Attribute_Reference
(Loc
,
4427 Attribute_Name
=> Name_Range_Length
,
4428 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4429 Analyze_And_Resolve
(N
, Typ
);
4434 elsif Is_Access_Type
(Ptyp
) then
4435 Apply_Access_Check
(N
);
4437 -- If the designated type is a packed array type, then we convert
4438 -- the reference to:
4441 -- xtyp'Pos (Pref'Last (Expr)) -
4442 -- xtyp'Pos (Pref'First (Expr)));
4444 -- This is a bit complex, but it is the easiest thing to do that
4445 -- works in all cases including enum types with holes xtyp here
4446 -- is the appropriate index type.
4449 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4453 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
4454 Xtyp
:= Get_Index_Subtype
(N
);
4457 Make_Attribute_Reference
(Loc
,
4458 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4459 Attribute_Name
=> Name_Max
,
4460 Expressions
=> New_List
(
4461 Make_Integer_Literal
(Loc
, 0),
4464 Make_Integer_Literal
(Loc
, 1),
4465 Make_Op_Subtract
(Loc
,
4467 Make_Attribute_Reference
(Loc
,
4468 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4469 Attribute_Name
=> Name_Pos
,
4470 Expressions
=> New_List
(
4471 Make_Attribute_Reference
(Loc
,
4472 Prefix
=> Duplicate_Subexpr
(Pref
),
4473 Attribute_Name
=> Name_Last
,
4475 New_Copy_List
(Exprs
)))),
4478 Make_Attribute_Reference
(Loc
,
4479 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4480 Attribute_Name
=> Name_Pos
,
4481 Expressions
=> New_List
(
4482 Make_Attribute_Reference
(Loc
,
4484 Duplicate_Subexpr_No_Checks
(Pref
),
4485 Attribute_Name
=> Name_First
,
4487 New_Copy_List
(Exprs
)))))))));
4489 Analyze_And_Resolve
(N
, Typ
);
4493 -- Otherwise leave it to the back end
4496 Apply_Universal_Integer_Attribute_Checks
(N
);
4500 -- Attribute Loop_Entry is replaced with a reference to a constant value
4501 -- which captures the prefix at the entry point of the related loop. The
4502 -- loop itself may be transformed into a conditional block.
4504 when Attribute_Loop_Entry
=>
4505 Expand_Loop_Entry_Attribute
(N
);
4511 -- Transforms 'Machine into a call to the floating-point attribute
4512 -- function Machine in Fat_xxx (where xxx is the root type).
4513 -- Expansion is avoided for cases the back end can handle directly.
4515 when Attribute_Machine
=>
4516 if not Is_Inline_Floating_Point_Attribute
(N
) then
4517 Expand_Fpt_Attribute_R
(N
);
4520 ----------------------
4521 -- Machine_Rounding --
4522 ----------------------
4524 -- Transforms 'Machine_Rounding into a call to the floating-point
4525 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4526 -- type). Expansion is avoided for cases the back end can handle
4529 when Attribute_Machine_Rounding
=>
4530 if not Is_Inline_Floating_Point_Attribute
(N
) then
4531 Expand_Fpt_Attribute_R
(N
);
4538 -- Machine_Size is equivalent to Object_Size, so transform it into
4539 -- Object_Size and that way the back end never sees Machine_Size.
4541 when Attribute_Machine_Size
=>
4543 Make_Attribute_Reference
(Loc
,
4544 Prefix
=> Prefix
(N
),
4545 Attribute_Name
=> Name_Object_Size
));
4547 Analyze_And_Resolve
(N
, Typ
);
4553 -- The only case that can get this far is the dynamic case of the old
4554 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4561 -- ityp (System.Mantissa.Mantissa_Value
4562 -- (Integer'Integer_Value (typ'First),
4563 -- Integer'Integer_Value (typ'Last)));
4565 when Attribute_Mantissa
=>
4568 Make_Function_Call
(Loc
,
4570 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4572 Parameter_Associations
=> New_List
(
4573 Make_Attribute_Reference
(Loc
,
4574 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4575 Attribute_Name
=> Name_Integer_Value
,
4576 Expressions
=> New_List
(
4577 Make_Attribute_Reference
(Loc
,
4578 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4579 Attribute_Name
=> Name_First
))),
4581 Make_Attribute_Reference
(Loc
,
4582 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4583 Attribute_Name
=> Name_Integer_Value
,
4584 Expressions
=> New_List
(
4585 Make_Attribute_Reference
(Loc
,
4586 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4587 Attribute_Name
=> Name_Last
)))))));
4589 Analyze_And_Resolve
(N
, Typ
);
4595 when Attribute_Max
=>
4596 Expand_Min_Max_Attribute
(N
);
4598 ----------------------------------
4599 -- Max_Size_In_Storage_Elements --
4600 ----------------------------------
4602 when Attribute_Max_Size_In_Storage_Elements
=> declare
4603 Typ
: constant Entity_Id
:= Etype
(N
);
4606 Conversion_Added
: Boolean := False;
4607 -- A flag which tracks whether the original attribute has been
4608 -- wrapped inside a type conversion.
4611 -- If the prefix is X'Class, we transform it into a direct reference
4612 -- to the class-wide type, because the back end must not see a 'Class
4613 -- reference. See also 'Size.
4615 if Is_Entity_Name
(Pref
)
4616 and then Is_Class_Wide_Type
(Entity
(Pref
))
4618 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4622 Apply_Universal_Integer_Attribute_Checks
(N
);
4624 -- The universal integer check may sometimes add a type conversion,
4625 -- retrieve the original attribute reference from the expression.
4629 if Nkind
(Attr
) = N_Type_Conversion
then
4630 Attr
:= Expression
(Attr
);
4631 Conversion_Added
:= True;
4634 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
4636 -- Heap-allocated controlled objects contain two extra pointers which
4637 -- are not part of the actual type. Transform the attribute reference
4638 -- into a runtime expression to add the size of the hidden header.
4640 if Needs_Finalization
(Ptyp
)
4641 and then not Header_Size_Added
(Attr
)
4643 Set_Header_Size_Added
(Attr
);
4646 -- P'Max_Size_In_Storage_Elements +
4647 -- Universal_Integer
4648 -- (Header_Size_With_Padding (Ptyp'Alignment))
4652 Left_Opnd
=> Relocate_Node
(Attr
),
4654 Convert_To
(Universal_Integer
,
4655 Make_Function_Call
(Loc
,
4658 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4660 Parameter_Associations
=> New_List
(
4661 Make_Attribute_Reference
(Loc
,
4663 New_Occurrence_Of
(Ptyp
, Loc
),
4664 Attribute_Name
=> Name_Alignment
))))));
4666 -- Add a conversion to the target type
4668 if not Conversion_Added
then
4670 Make_Type_Conversion
(Loc
,
4671 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4672 Expression
=> Relocate_Node
(Attr
)));
4680 --------------------
4681 -- Mechanism_Code --
4682 --------------------
4684 when Attribute_Mechanism_Code
=>
4686 -- We must replace the prefix in the renamed case
4688 if Is_Entity_Name
(Pref
)
4689 and then Present
(Alias
(Entity
(Pref
)))
4691 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4698 when Attribute_Min
=>
4699 Expand_Min_Max_Attribute
(N
);
4705 when Attribute_Mod
=> Mod_Case
: declare
4706 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4707 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
4708 Modv
: constant Uint
:= Modulus
(Btyp
);
4712 -- This is not so simple. The issue is what type to use for the
4713 -- computation of the modular value.
4715 -- The easy case is when the modulus value is within the bounds
4716 -- of the signed integer type of the argument. In this case we can
4717 -- just do the computation in that signed integer type, and then
4718 -- do an ordinary conversion to the target type.
4720 if Modv
<= Expr_Value
(Hi
) then
4725 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4727 -- Here we know that the modulus is larger than type'Last of the
4728 -- integer type. There are two cases to consider:
4730 -- a) The integer value is non-negative. In this case, it is
4731 -- returned as the result (since it is less than the modulus).
4733 -- b) The integer value is negative. In this case, we know that the
4734 -- result is modulus + value, where the value might be as small as
4735 -- -modulus. The trouble is what type do we use to do the subtract.
4736 -- No type will do, since modulus can be as big as 2**64, and no
4737 -- integer type accommodates this value. Let's do bit of algebra
4740 -- = modulus - (-value)
4741 -- = (modulus - 1) - (-value - 1)
4743 -- Now modulus - 1 is certainly in range of the modular type.
4744 -- -value is in the range 1 .. modulus, so -value -1 is in the
4745 -- range 0 .. modulus-1 which is in range of the modular type.
4746 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4747 -- which we can compute using the integer base type.
4749 -- Once this is done we analyze the if expression without range
4750 -- checks, because we know everything is in range, and we want
4751 -- to prevent spurious warnings on either branch.
4755 Make_If_Expression
(Loc
,
4756 Expressions
=> New_List
(
4758 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4759 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4762 Duplicate_Subexpr_No_Checks
(Arg
)),
4764 Make_Op_Subtract
(Loc
,
4766 Make_Integer_Literal
(Loc
,
4767 Intval
=> Modv
- 1),
4773 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4775 Make_Integer_Literal
(Loc
,
4776 Intval
=> 1))))))));
4780 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4787 -- Transforms 'Model into a call to the floating-point attribute
4788 -- function Model in Fat_xxx (where xxx is the root type).
4789 -- Expansion is avoided for cases the back end can handle directly.
4791 when Attribute_Model
=>
4792 if not Is_Inline_Floating_Point_Attribute
(N
) then
4793 Expand_Fpt_Attribute_R
(N
);
4800 -- The processing for Object_Size shares the processing for Size
4806 when Attribute_Old
=> Old
: declare
4807 Typ
: constant Entity_Id
:= Etype
(N
);
4808 CW_Temp
: Entity_Id
;
4815 -- Generating C code we don't need to expand this attribute when
4816 -- we are analyzing the internally built nested postconditions
4817 -- procedure since it will be expanded inline (and later it will
4818 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4819 -- performed in such case then the compiler generates unreferenced
4820 -- extra temporaries.
4822 if Modify_Tree_For_C
4823 and then Chars
(Current_Scope
) = Name_uPostconditions
4828 -- Climb the parent chain looking for subprogram _Postconditions
4831 while Present
(Subp
) loop
4832 exit when Nkind
(Subp
) = N_Subprogram_Body
4833 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4835 -- If assertions are disabled, no need to create the declaration
4836 -- that preserves the value. The postcondition pragma in which
4837 -- 'Old appears will be checked or disabled according to the
4838 -- current policy in effect.
4840 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4844 Subp
:= Parent
(Subp
);
4847 -- 'Old can only appear in a postcondition, the generated body of
4848 -- _Postconditions must be in the tree (or inlined if we are
4849 -- generating C code).
4853 or else (Modify_Tree_For_C
and then In_Inlined_Body
));
4855 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4857 -- Set the entity kind now in order to mark the temporary as a
4858 -- handler of attribute 'Old's prefix.
4860 Set_Ekind
(Temp
, E_Constant
);
4861 Set_Stores_Attribute_Old_Prefix
(Temp
);
4863 -- Push the scope of the related subprogram where _Postcondition
4864 -- resides as this ensures that the object will be analyzed in the
4867 if Present
(Subp
) then
4868 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4870 -- No need to push the scope when generating C code since the
4871 -- _Postcondition procedure has been inlined.
4873 else pragma Assert
(Modify_Tree_For_C
);
4874 pragma Assert
(In_Inlined_Body
);
4878 -- Locate the insertion place of the internal temporary that saves
4881 if Present
(Subp
) then
4884 -- Generating C, the postcondition procedure has been inlined and the
4885 -- temporary is added before the first declaration of the enclosing
4888 else pragma Assert
(Modify_Tree_For_C
);
4890 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
4891 Ins_Nod
:= Parent
(Ins_Nod
);
4894 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
4897 -- Preserve the tag of the prefix by offering a specific view of the
4898 -- class-wide version of the prefix.
4900 if Is_Tagged_Type
(Typ
) then
4903 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4905 CW_Temp
:= Make_Temporary
(Loc
, 'T');
4906 CW_Typ
:= Class_Wide_Type
(Typ
);
4908 Insert_Before_And_Analyze
(Ins_Nod
,
4909 Make_Object_Declaration
(Loc
,
4910 Defining_Identifier
=> CW_Temp
,
4911 Constant_Present
=> True,
4912 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
4914 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
4917 -- Temp : Typ renames Typ (CW_Temp);
4919 Insert_Before_And_Analyze
(Ins_Nod
,
4920 Make_Object_Renaming_Declaration
(Loc
,
4921 Defining_Identifier
=> Temp
,
4922 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4924 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
4930 -- Temp : constant Typ := Pref;
4932 Insert_Before_And_Analyze
(Ins_Nod
,
4933 Make_Object_Declaration
(Loc
,
4934 Defining_Identifier
=> Temp
,
4935 Constant_Present
=> True,
4936 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
4937 Expression
=> Relocate_Node
(Pref
)));
4940 if Present
(Subp
) then
4944 -- Ensure that the prefix of attribute 'Old is valid. The check must
4945 -- be inserted after the expansion of the attribute has taken place
4946 -- to reflect the new placement of the prefix.
4948 if Validity_Checks_On
and then Validity_Check_Operands
then
4949 Ensure_Valid
(Pref
);
4952 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4955 ----------------------
4956 -- Overlaps_Storage --
4957 ----------------------
4959 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4960 Loc
: constant Source_Ptr
:= Sloc
(N
);
4962 X
: constant Node_Id
:= Prefix
(N
);
4963 Y
: constant Node_Id
:= First
(Expressions
(N
));
4966 X_Addr
, Y_Addr
: Node_Id
;
4967 -- the expressions for their integer addresses
4969 X_Size
, Y_Size
: Node_Id
;
4970 -- the expressions for their sizes
4975 -- Attribute expands into:
4977 -- if X'Address < Y'address then
4978 -- (X'address + X'Size - 1) >= Y'address
4980 -- (Y'address + Y'size - 1) >= X'Address
4983 -- with the proper address operations. We convert addresses to
4984 -- integer addresses to use predefined arithmetic. The size is
4985 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4986 -- to prevent the appearance of the same node in two places in
4990 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4991 Make_Attribute_Reference
(Loc
,
4992 Attribute_Name
=> Name_Address
,
4993 Prefix
=> New_Copy_Tree
(X
)));
4996 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4997 Make_Attribute_Reference
(Loc
,
4998 Attribute_Name
=> Name_Address
,
4999 Prefix
=> New_Copy_Tree
(Y
)));
5002 Make_Op_Divide
(Loc
,
5004 Make_Attribute_Reference
(Loc
,
5005 Attribute_Name
=> Name_Size
,
5006 Prefix
=> New_Copy_Tree
(X
)),
5008 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5011 Make_Op_Divide
(Loc
,
5013 Make_Attribute_Reference
(Loc
,
5014 Attribute_Name
=> Name_Size
,
5015 Prefix
=> New_Copy_Tree
(Y
)),
5017 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5021 Left_Opnd
=> X_Addr
,
5022 Right_Opnd
=> Y_Addr
);
5025 Make_If_Expression
(Loc
, New_List
(
5031 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
5033 Make_Op_Subtract
(Loc
,
5034 Left_Opnd
=> X_Size
,
5035 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5036 Right_Opnd
=> Y_Addr
),
5041 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
5043 Make_Op_Subtract
(Loc
,
5044 Left_Opnd
=> Y_Size
,
5045 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5046 Right_Opnd
=> X_Addr
))));
5048 Analyze_And_Resolve
(N
, Standard_Boolean
);
5049 end Overlaps_Storage
;
5055 when Attribute_Output
=> Output
: declare
5056 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5057 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5065 -- If no underlying type, we have an error that will be diagnosed
5066 -- elsewhere, so here we just completely ignore the expansion.
5072 -- Stream operations can appear in user code even if the restriction
5073 -- No_Streams is active (for example, when instantiating a predefined
5074 -- container). In that case rewrite the attribute as a Raise to
5075 -- prevent any run-time use.
5077 if Restriction_Active
(No_Streams
) then
5079 Make_Raise_Program_Error
(Sloc
(N
),
5080 Reason
=> PE_Stream_Operation_Not_Allowed
));
5081 Set_Etype
(N
, Standard_Void_Type
);
5085 -- If TSS for Output is present, just call it
5087 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
5089 if Present
(Pname
) then
5093 -- If there is a Stream_Convert pragma, use it, we rewrite
5095 -- sourcetyp'Output (stream, Item)
5099 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5101 -- where strmwrite is the given Write function that converts an
5102 -- argument of type sourcetyp or a type acctyp, from which it is
5103 -- derived to type strmtyp. The conversion to acttyp is required
5104 -- for the derived case.
5106 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5108 if Present
(Prag
) then
5110 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
5111 Wfunc
:= Entity
(Expression
(Arg3
));
5114 Make_Attribute_Reference
(Loc
,
5115 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
5116 Attribute_Name
=> Name_Output
,
5117 Expressions
=> New_List
(
5118 Relocate_Node
(First
(Exprs
)),
5119 Make_Function_Call
(Loc
,
5120 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
5121 Parameter_Associations
=> New_List
(
5122 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
5123 Relocate_Node
(Next
(First
(Exprs
)))))))));
5128 -- For elementary types, we call the W_xxx routine directly. Note
5129 -- that the effect of Write and Output is identical for the case
5130 -- of an elementary type (there are no discriminants or bounds).
5132 elsif Is_Elementary_Type
(U_Type
) then
5134 -- A special case arises if we have a defined _Write routine,
5135 -- since in this case we are required to call this routine.
5138 Typ
: Entity_Id
:= P_Type
;
5140 if Present
(Full_View
(Typ
)) then
5141 Typ
:= Full_View
(Typ
);
5144 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Write
)) then
5145 Build_Record_Or_Elementary_Output_Procedure
5146 (Loc
, Typ
, Decl
, Pname
);
5147 Insert_Action
(N
, Decl
);
5149 -- For normal cases, we call the W_xxx routine directly
5152 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
5160 elsif Is_Array_Type
(U_Type
) then
5161 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
5162 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5164 -- Class-wide case, first output external tag, then dispatch
5165 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5167 elsif Is_Class_Wide_Type
(P_Type
) then
5169 -- No need to do anything else compiling under restriction
5170 -- No_Dispatching_Calls. During the semantic analysis we
5171 -- already notified such violation.
5173 if Restriction_Active
(No_Dispatching_Calls
) then
5178 Strm
: constant Node_Id
:= First
(Exprs
);
5179 Item
: constant Node_Id
:= Next
(Strm
);
5182 -- Ada 2005 (AI-344): Check that the accessibility level
5183 -- of the type of the output object is not deeper than
5184 -- that of the attribute's prefix type.
5186 -- if Get_Access_Level (Item'Tag)
5187 -- /= Get_Access_Level (P_Type'Tag)
5192 -- String'Output (Strm, External_Tag (Item'Tag));
5194 -- We cannot figure out a practical way to implement this
5195 -- accessibility check on virtual machines, so we omit it.
5197 if Ada_Version
>= Ada_2005
5198 and then Tagged_Type_Expansion
5201 Make_Implicit_If_Statement
(N
,
5205 Build_Get_Access_Level
(Loc
,
5206 Make_Attribute_Reference
(Loc
,
5209 Duplicate_Subexpr
(Item
,
5211 Attribute_Name
=> Name_Tag
)),
5214 Make_Integer_Literal
(Loc
,
5215 Type_Access_Level
(P_Type
))),
5218 New_List
(Make_Raise_Statement
(Loc
,
5220 RTE
(RE_Tag_Error
), Loc
)))));
5224 Make_Attribute_Reference
(Loc
,
5225 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
5226 Attribute_Name
=> Name_Output
,
5227 Expressions
=> New_List
(
5228 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
5229 Make_Function_Call
(Loc
,
5231 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
5232 Parameter_Associations
=> New_List
(
5233 Make_Attribute_Reference
(Loc
,
5236 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
5237 Attribute_Name
=> Name_Tag
))))));
5240 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5242 -- Tagged type case, use the primitive Output function
5244 elsif Is_Tagged_Type
(U_Type
) then
5245 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5247 -- All other record type cases, including protected records.
5248 -- The latter only arise for expander generated code for
5249 -- handling shared passive partition access.
5253 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5255 -- Ada 2005 (AI-216): Program_Error is raised when executing
5256 -- the default implementation of the Output attribute of an
5257 -- unchecked union type if the type lacks default discriminant
5260 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5261 and then No
(Discriminant_Constraint
(U_Type
))
5264 Make_Raise_Program_Error
(Loc
,
5265 Reason
=> PE_Unchecked_Union_Restriction
));
5270 Build_Record_Or_Elementary_Output_Procedure
5271 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
5272 Insert_Action
(N
, Decl
);
5276 -- If we fall through, Pname is the name of the procedure to call
5278 Rewrite_Stream_Proc_Call
(Pname
);
5285 -- For enumeration types with a standard representation, Pos is
5286 -- handled by the back end.
5288 -- For enumeration types, with a non-standard representation we generate
5289 -- a call to the _Rep_To_Pos function created when the type was frozen.
5290 -- The call has the form
5292 -- _rep_to_pos (expr, flag)
5294 -- The parameter flag is True if range checks are enabled, causing
5295 -- Program_Error to be raised if the expression has an invalid
5296 -- representation, and False if range checks are suppressed.
5298 -- For integer types, Pos is equivalent to a simple integer
5299 -- conversion and we rewrite it as such
5301 when Attribute_Pos
=> Pos
: declare
5302 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
5305 -- Deal with zero/non-zero boolean values
5307 if Is_Boolean_Type
(Etyp
) then
5308 Adjust_Condition
(First
(Exprs
));
5309 Etyp
:= Standard_Boolean
;
5310 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5313 -- Case of enumeration type
5315 if Is_Enumeration_Type
(Etyp
) then
5317 -- Non-standard enumeration type (generate call)
5319 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5320 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5323 Make_Function_Call
(Loc
,
5325 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5326 Parameter_Associations
=> Exprs
)));
5328 Analyze_And_Resolve
(N
, Typ
);
5330 -- Standard enumeration type (do universal integer check)
5333 Apply_Universal_Integer_Attribute_Checks
(N
);
5336 -- Deal with integer types (replace by conversion)
5338 elsif Is_Integer_Type
(Etyp
) then
5339 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
5340 Analyze_And_Resolve
(N
, Typ
);
5349 -- We compute this if a component clause was present, otherwise we leave
5350 -- the computation up to the back end, since we don't know what layout
5353 when Attribute_Position
=> Position_Attr
: declare
5354 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5357 if Present
(Component_Clause
(CE
)) then
5359 -- In Ada 2005 (or later) if we have the non-default bit order,
5360 -- then we return the original value as given in the component
5361 -- clause (RM 2005 13.5.2(2/2)).
5363 if Ada_Version
>= Ada_2005
5364 and then Reverse_Bit_Order
(Scope
(CE
))
5367 Make_Integer_Literal
(Loc
,
5368 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
5370 -- Otherwise (Ada 83 or 95, or default bit order specified in
5371 -- later Ada version), return the normalized value.
5375 Make_Integer_Literal
(Loc
,
5376 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
5379 Analyze_And_Resolve
(N
, Typ
);
5381 -- If back end is doing things, just apply universal integer checks
5384 Apply_Universal_Integer_Attribute_Checks
(N
);
5392 -- 1. Deal with enumeration types with holes.
5393 -- 2. For floating-point, generate call to attribute function.
5394 -- 3. For other cases, deal with constraint checking.
5396 when Attribute_Pred
=> Pred
: declare
5397 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5401 -- For enumeration types with non-standard representations, we
5402 -- expand typ'Pred (x) into
5404 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5406 -- If the representation is contiguous, we compute instead
5407 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5408 -- The conversion function Enum_Pos_To_Rep is defined on the
5409 -- base type, not the subtype, so we have to use the base type
5410 -- explicitly for this and other enumeration attributes.
5412 if Is_Enumeration_Type
(Ptyp
)
5413 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5415 if Has_Contiguous_Rep
(Etyp
) then
5417 Unchecked_Convert_To
(Ptyp
,
5420 Make_Integer_Literal
(Loc
,
5421 Enumeration_Rep
(First_Literal
(Ptyp
))),
5423 Make_Function_Call
(Loc
,
5426 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5428 Parameter_Associations
=>
5430 Unchecked_Convert_To
(Ptyp
,
5431 Make_Op_Subtract
(Loc
,
5433 Unchecked_Convert_To
(Standard_Integer
,
5434 Relocate_Node
(First
(Exprs
))),
5436 Make_Integer_Literal
(Loc
, 1))),
5437 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5440 -- Add Boolean parameter True, to request program errror if
5441 -- we have a bad representation on our hands. If checks are
5442 -- suppressed, then add False instead
5444 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5446 Make_Indexed_Component
(Loc
,
5449 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5450 Expressions
=> New_List
(
5451 Make_Op_Subtract
(Loc
,
5453 Make_Function_Call
(Loc
,
5456 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5457 Parameter_Associations
=> Exprs
),
5458 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5461 Analyze_And_Resolve
(N
, Typ
);
5463 -- For floating-point, we transform 'Pred into a call to the Pred
5464 -- floating-point attribute function in Fat_xxx (xxx is root type).
5465 -- Note that this function takes care of the overflow case.
5467 elsif Is_Floating_Point_Type
(Ptyp
) then
5468 Expand_Fpt_Attribute_R
(N
);
5469 Analyze_And_Resolve
(N
, Typ
);
5471 -- For modular types, nothing to do (no overflow, since wraps)
5473 elsif Is_Modular_Integer_Type
(Ptyp
) then
5476 -- For other types, if argument is marked as needing a range check or
5477 -- overflow checking is enabled, we must generate a check.
5479 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5480 or else Do_Range_Check
(First
(Exprs
))
5482 Set_Do_Range_Check
(First
(Exprs
), False);
5483 Expand_Pred_Succ_Attribute
(N
);
5491 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5493 -- We rewrite X'Priority as the following run-time call:
5495 -- Get_Ceiling (X._Object)
5497 -- Note that although X'Priority is notionally an object, it is quite
5498 -- deliberately not defined as an aliased object in the RM. This means
5499 -- that it works fine to rewrite it as a call, without having to worry
5500 -- about complications that would other arise from X'Priority'Access,
5501 -- which is illegal, because of the lack of aliasing.
5503 when Attribute_Priority
=> Priority
: declare
5505 Conctyp
: Entity_Id
;
5506 New_Itype
: Entity_Id
;
5507 Object_Parm
: Node_Id
;
5509 RT_Subprg_Name
: Node_Id
;
5512 -- Look for the enclosing concurrent type
5514 Conctyp
:= Current_Scope
;
5515 while not Is_Concurrent_Type
(Conctyp
) loop
5516 Conctyp
:= Scope
(Conctyp
);
5519 pragma Assert
(Is_Protected_Type
(Conctyp
));
5521 -- Generate the actual of the call
5523 Subprg
:= Current_Scope
;
5524 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5525 Subprg
:= Scope
(Subprg
);
5528 -- Use of 'Priority inside protected entries and barriers (in both
5529 -- cases the type of the first formal of their expanded subprogram
5532 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5535 -- In the expansion of protected entries the type of the first
5536 -- formal of the Protected_Body_Subprogram is an Address. In order
5537 -- to reference the _object component we generate:
5539 -- type T is access p__ptTV;
5542 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5543 Set_Etype
(New_Itype
, New_Itype
);
5544 Set_Directly_Designated_Type
(New_Itype
,
5545 Corresponding_Record_Type
(Conctyp
));
5546 Freeze_Itype
(New_Itype
, N
);
5549 -- T!(O)._object'unchecked_access
5552 Make_Attribute_Reference
(Loc
,
5554 Make_Selected_Component
(Loc
,
5556 Unchecked_Convert_To
(New_Itype
,
5558 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5560 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5561 Attribute_Name
=> Name_Unchecked_Access
);
5563 -- Use of 'Priority inside a protected subprogram
5567 Make_Attribute_Reference
(Loc
,
5569 Make_Selected_Component
(Loc
,
5572 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5574 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5575 Attribute_Name
=> Name_Unchecked_Access
);
5578 -- Select the appropriate run-time subprogram
5580 if Number_Entries
(Conctyp
) = 0 then
5581 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5583 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5587 Make_Function_Call
(Loc
,
5588 Name
=> RT_Subprg_Name
,
5589 Parameter_Associations
=> New_List
(Object_Parm
));
5593 -- Avoid the generation of extra checks on the pointer to the
5594 -- protected object.
5596 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5603 when Attribute_Range_Length
=>
5605 -- The only special processing required is for the case where
5606 -- Range_Length is applied to an enumeration type with holes.
5607 -- In this case we transform
5613 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5615 -- So that the result reflects the proper Pos values instead
5616 -- of the underlying representations.
5618 if Is_Enumeration_Type
(Ptyp
)
5619 and then Has_Non_Standard_Rep
(Ptyp
)
5624 Make_Op_Subtract
(Loc
,
5626 Make_Attribute_Reference
(Loc
,
5627 Attribute_Name
=> Name_Pos
,
5628 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5629 Expressions
=> New_List
(
5630 Make_Attribute_Reference
(Loc
,
5631 Attribute_Name
=> Name_Last
,
5633 New_Occurrence_Of
(Ptyp
, Loc
)))),
5636 Make_Attribute_Reference
(Loc
,
5637 Attribute_Name
=> Name_Pos
,
5638 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5639 Expressions
=> New_List
(
5640 Make_Attribute_Reference
(Loc
,
5641 Attribute_Name
=> Name_First
,
5643 New_Occurrence_Of
(Ptyp
, Loc
))))),
5645 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5647 Analyze_And_Resolve
(N
, Typ
);
5649 -- For all other cases, the attribute is handled by the back end, but
5650 -- we need to deal with the case of the range check on a universal
5654 Apply_Universal_Integer_Attribute_Checks
(N
);
5661 when Attribute_Read
=> Read
: declare
5662 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5663 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
5664 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5674 -- If no underlying type, we have an error that will be diagnosed
5675 -- elsewhere, so here we just completely ignore the expansion.
5681 -- Stream operations can appear in user code even if the restriction
5682 -- No_Streams is active (for example, when instantiating a predefined
5683 -- container). In that case rewrite the attribute as a Raise to
5684 -- prevent any run-time use.
5686 if Restriction_Active
(No_Streams
) then
5688 Make_Raise_Program_Error
(Sloc
(N
),
5689 Reason
=> PE_Stream_Operation_Not_Allowed
));
5690 Set_Etype
(N
, B_Type
);
5694 -- The simple case, if there is a TSS for Read, just call it
5696 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
5698 if Present
(Pname
) then
5702 -- If there is a Stream_Convert pragma, use it, we rewrite
5704 -- sourcetyp'Read (stream, Item)
5708 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5710 -- where strmread is the given Read function that converts an
5711 -- argument of type strmtyp to type sourcetyp or a type from which
5712 -- it is derived. The conversion to sourcetyp is required in the
5715 -- A special case arises if Item is a type conversion in which
5716 -- case, we have to expand to:
5718 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5720 -- where Itemx is the expression of the type conversion (i.e.
5721 -- the actual object), and typex is the type of Itemx.
5723 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5725 if Present
(Prag
) then
5726 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
5727 Rfunc
:= Entity
(Expression
(Arg2
));
5728 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5730 OK_Convert_To
(B_Type
,
5731 Make_Function_Call
(Loc
,
5732 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
5733 Parameter_Associations
=> New_List
(
5734 Make_Attribute_Reference
(Loc
,
5737 (Etype
(First_Formal
(Rfunc
)), Loc
),
5738 Attribute_Name
=> Name_Input
,
5739 Expressions
=> New_List
(
5740 Relocate_Node
(First
(Exprs
)))))));
5742 if Nkind
(Lhs
) = N_Type_Conversion
then
5743 Lhs
:= Expression
(Lhs
);
5744 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5748 Make_Assignment_Statement
(Loc
,
5750 Expression
=> Rhs
));
5751 Set_Assignment_OK
(Lhs
);
5755 -- For elementary types, we call the I_xxx routine using the first
5756 -- parameter and then assign the result into the second parameter.
5757 -- We set Assignment_OK to deal with the conversion case.
5759 elsif Is_Elementary_Type
(U_Type
) then
5765 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5766 Rhs
:= Build_Elementary_Input_Call
(N
);
5768 if Nkind
(Lhs
) = N_Type_Conversion
then
5769 Lhs
:= Expression
(Lhs
);
5770 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5773 Set_Assignment_OK
(Lhs
);
5776 Make_Assignment_Statement
(Loc
,
5778 Expression
=> Rhs
));
5786 elsif Is_Array_Type
(U_Type
) then
5787 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
5788 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5790 -- Tagged type case, use the primitive Read function. Note that
5791 -- this will dispatch in the class-wide case which is what we want
5793 elsif Is_Tagged_Type
(U_Type
) then
5794 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
5796 -- All other record type cases, including protected records. The
5797 -- latter only arise for expander generated code for handling
5798 -- shared passive partition access.
5802 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5804 -- Ada 2005 (AI-216): Program_Error is raised when executing
5805 -- the default implementation of the Read attribute of an
5806 -- Unchecked_Union type. We replace the attribute with a
5807 -- raise statement (rather than inserting it before) to handle
5808 -- properly the case of an unchecked union that is a record
5811 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
5813 Make_Raise_Program_Error
(Loc
,
5814 Reason
=> PE_Unchecked_Union_Restriction
));
5815 Set_Etype
(N
, B_Type
);
5819 if Has_Discriminants
(U_Type
)
5821 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5823 Build_Mutable_Record_Read_Procedure
5824 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5826 Build_Record_Read_Procedure
5827 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5830 -- Suppress checks, uninitialized or otherwise invalid
5831 -- data does not cause constraint errors to be raised for
5832 -- a complete record read.
5834 Insert_Action
(N
, Decl
, All_Checks
);
5838 Rewrite_Stream_Proc_Call
(Pname
);
5845 -- Ref is identical to To_Address, see To_Address for processing
5851 -- Transforms 'Remainder into a call to the floating-point attribute
5852 -- function Remainder in Fat_xxx (where xxx is the root type)
5854 when Attribute_Remainder
=>
5855 Expand_Fpt_Attribute_RR
(N
);
5861 -- Transform 'Result into reference to _Result formal. At the point
5862 -- where a legal 'Result attribute is expanded, we know that we are in
5863 -- the context of a _Postcondition function with a _Result parameter.
5865 when Attribute_Result
=>
5866 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
5867 Analyze_And_Resolve
(N
, Typ
);
5873 -- The handling of the Round attribute is quite delicate. The processing
5874 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5875 -- semantics of Round, but we do not want anything to do with universal
5876 -- real at runtime, since this corresponds to using floating-point
5879 -- What we have now is that the Etype of the Round attribute correctly
5880 -- indicates the final result type. The operand of the Round is the
5881 -- conversion to universal real, described above, and the operand of
5882 -- this conversion is the actual operand of Round, which may be the
5883 -- special case of a fixed point multiplication or division (Etype =
5886 -- The exapander will expand first the operand of the conversion, then
5887 -- the conversion, and finally the round attribute itself, since we
5888 -- always work inside out. But we cannot simply process naively in this
5889 -- order. In the semantic world where universal fixed and real really
5890 -- exist and have infinite precision, there is no problem, but in the
5891 -- implementation world, where universal real is a floating-point type,
5892 -- we would get the wrong result.
5894 -- So the approach is as follows. First, when expanding a multiply or
5895 -- divide whose type is universal fixed, we do nothing at all, instead
5896 -- deferring the operation till later.
5898 -- The actual processing is done in Expand_N_Type_Conversion which
5899 -- handles the special case of Round by looking at its parent to see if
5900 -- it is a Round attribute, and if it is, handling the conversion (or
5901 -- its fixed multiply/divide child) in an appropriate manner.
5903 -- This means that by the time we get to expanding the Round attribute
5904 -- itself, the Round is nothing more than a type conversion (and will
5905 -- often be a null type conversion), so we just replace it with the
5906 -- appropriate conversion operation.
5908 when Attribute_Round
=>
5910 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
5911 Analyze_And_Resolve
(N
);
5917 -- Transforms 'Rounding into a call to the floating-point attribute
5918 -- function Rounding in Fat_xxx (where xxx is the root type)
5919 -- Expansion is avoided for cases the back end can handle directly.
5921 when Attribute_Rounding
=>
5922 if not Is_Inline_Floating_Point_Attribute
(N
) then
5923 Expand_Fpt_Attribute_R
(N
);
5930 -- Transforms 'Scaling into a call to the floating-point attribute
5931 -- function Scaling in Fat_xxx (where xxx is the root type)
5933 when Attribute_Scaling
=>
5934 Expand_Fpt_Attribute_RI
(N
);
5936 -------------------------
5937 -- Simple_Storage_Pool --
5938 -------------------------
5940 when Attribute_Simple_Storage_Pool
=>
5942 Make_Type_Conversion
(Loc
,
5943 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5944 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5945 Analyze_And_Resolve
(N
, Typ
);
5951 when Attribute_Object_Size
5953 | Attribute_Value_Size
5954 | Attribute_VADS_Size
5961 -- Processing for VADS_Size case. Note that this processing
5962 -- removes all traces of VADS_Size from the tree, and completes
5963 -- all required processing for VADS_Size by translating the
5964 -- attribute reference to an appropriate Size or Object_Size
5967 if Id
= Attribute_VADS_Size
5968 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5970 -- If the size is specified, then we simply use the specified
5971 -- size. This applies to both types and objects. The size of an
5972 -- object can be specified in the following ways:
5974 -- An explicit size object is given for an object
5975 -- A component size is specified for an indexed component
5976 -- A component clause is specified for a selected component
5977 -- The object is a component of a packed composite object
5979 -- If the size is specified, then VADS_Size of an object
5981 if (Is_Entity_Name
(Pref
)
5982 and then Present
(Size_Clause
(Entity
(Pref
))))
5984 (Nkind
(Pref
) = N_Component_Clause
5985 and then (Present
(Component_Clause
5986 (Entity
(Selector_Name
(Pref
))))
5987 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5989 (Nkind
(Pref
) = N_Indexed_Component
5990 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5991 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5993 Set_Attribute_Name
(N
, Name_Size
);
5995 -- Otherwise if we have an object rather than a type, then
5996 -- the VADS_Size attribute applies to the type of the object,
5997 -- rather than the object itself. This is one of the respects
5998 -- in which VADS_Size differs from Size.
6001 if (not Is_Entity_Name
(Pref
)
6002 or else not Is_Type
(Entity
(Pref
)))
6003 and then (Is_Scalar_Type
(Ptyp
)
6004 or else Is_Constrained
(Ptyp
))
6006 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
6009 -- For a scalar type for which no size was explicitly given,
6010 -- VADS_Size means Object_Size. This is the other respect in
6011 -- which VADS_Size differs from Size.
6013 if Is_Scalar_Type
(Ptyp
)
6014 and then No
(Size_Clause
(Ptyp
))
6016 Set_Attribute_Name
(N
, Name_Object_Size
);
6018 -- In all other cases, Size and VADS_Size are the sane
6021 Set_Attribute_Name
(N
, Name_Size
);
6026 -- If the prefix is X'Class, transform it into a direct reference
6027 -- to the class-wide type, because the back end must not see a
6028 -- 'Class reference.
6030 if Is_Entity_Name
(Pref
)
6031 and then Is_Class_Wide_Type
(Entity
(Pref
))
6033 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
6036 -- For X'Size applied to an object of a class-wide type, transform
6037 -- X'Size into a call to the primitive operation _Size applied to
6040 elsif Is_Class_Wide_Type
(Ptyp
) then
6042 -- No need to do anything else compiling under restriction
6043 -- No_Dispatching_Calls. During the semantic analysis we
6044 -- already noted this restriction violation.
6046 if Restriction_Active
(No_Dispatching_Calls
) then
6051 Make_Function_Call
(Loc
,
6053 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
6054 Parameter_Associations
=> New_List
(Pref
));
6056 if Typ
/= Standard_Long_Long_Integer
then
6058 -- The context is a specific integer type with which the
6059 -- original attribute was compatible. The function has a
6060 -- specific type as well, so to preserve the compatibility
6061 -- we must convert explicitly.
6063 New_Node
:= Convert_To
(Typ
, New_Node
);
6066 Rewrite
(N
, New_Node
);
6067 Analyze_And_Resolve
(N
, Typ
);
6070 -- Case of known RM_Size of a type
6072 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
6073 and then Is_Entity_Name
(Pref
)
6074 and then Is_Type
(Entity
(Pref
))
6075 and then Known_Static_RM_Size
(Entity
(Pref
))
6077 Siz
:= RM_Size
(Entity
(Pref
));
6079 -- Case of known Esize of a type
6081 elsif Id
= Attribute_Object_Size
6082 and then Is_Entity_Name
(Pref
)
6083 and then Is_Type
(Entity
(Pref
))
6084 and then Known_Static_Esize
(Entity
(Pref
))
6086 Siz
:= Esize
(Entity
(Pref
));
6088 -- Case of known size of object
6090 elsif Id
= Attribute_Size
6091 and then Is_Entity_Name
(Pref
)
6092 and then Is_Object
(Entity
(Pref
))
6093 and then Known_Esize
(Entity
(Pref
))
6094 and then Known_Static_Esize
(Entity
(Pref
))
6096 Siz
:= Esize
(Entity
(Pref
));
6098 -- For an array component, we can do Size in the front end if the
6099 -- component_size of the array is set.
6101 elsif Nkind
(Pref
) = N_Indexed_Component
then
6102 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
6104 -- For a record component, we can do Size in the front end if
6105 -- there is a component clause, or if the record is packed and the
6106 -- component's size is known at compile time.
6108 elsif Nkind
(Pref
) = N_Selected_Component
then
6110 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
6111 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
6114 if Present
(Component_Clause
(Comp
)) then
6115 Siz
:= Esize
(Comp
);
6117 elsif Is_Packed
(Rec
) then
6118 Siz
:= RM_Size
(Ptyp
);
6121 Apply_Universal_Integer_Attribute_Checks
(N
);
6126 -- All other cases are handled by the back end
6129 Apply_Universal_Integer_Attribute_Checks
(N
);
6131 -- If Size is applied to a formal parameter that is of a packed
6132 -- array subtype, then apply Size to the actual subtype.
6134 if Is_Entity_Name
(Pref
)
6135 and then Is_Formal
(Entity
(Pref
))
6136 and then Is_Array_Type
(Ptyp
)
6137 and then Is_Packed
(Ptyp
)
6140 Make_Attribute_Reference
(Loc
,
6142 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
6143 Attribute_Name
=> Name_Size
));
6144 Analyze_And_Resolve
(N
, Typ
);
6147 -- If Size applies to a dereference of an access to
6148 -- unconstrained packed array, the back end needs to see its
6149 -- unconstrained nominal type, but also a hint to the actual
6150 -- constrained type.
6152 if Nkind
(Pref
) = N_Explicit_Dereference
6153 and then Is_Array_Type
(Ptyp
)
6154 and then not Is_Constrained
(Ptyp
)
6155 and then Is_Packed
(Ptyp
)
6157 Set_Actual_Designated_Subtype
(Pref
,
6158 Get_Actual_Subtype
(Pref
));
6164 -- Common processing for record and array component case
6166 if Siz
/= No_Uint
and then Siz
/= 0 then
6168 CS
: constant Boolean := Comes_From_Source
(N
);
6171 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
6173 -- This integer literal is not a static expression. We do
6174 -- not call Analyze_And_Resolve here, because this would
6175 -- activate the circuit for deciding that a static value
6176 -- was out of range, and we don't want that.
6178 -- So just manually set the type, mark the expression as
6179 -- non-static, and then ensure that the result is checked
6180 -- properly if the attribute comes from source (if it was
6181 -- internally generated, we never need a constraint check).
6184 Set_Is_Static_Expression
(N
, False);
6187 Apply_Constraint_Check
(N
, Typ
);
6197 when Attribute_Storage_Pool
=>
6199 Make_Type_Conversion
(Loc
,
6200 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
6201 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
6202 Analyze_And_Resolve
(N
, Typ
);
6208 when Attribute_Storage_Size
=> Storage_Size
: declare
6209 Alloc_Op
: Entity_Id
:= Empty
;
6213 -- Access type case, always go to the root type
6215 -- The case of access types results in a value of zero for the case
6216 -- where no storage size attribute clause has been given. If a
6217 -- storage size has been given, then the attribute is converted
6218 -- to a reference to the variable used to hold this value.
6220 if Is_Access_Type
(Ptyp
) then
6221 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
6223 Make_Attribute_Reference
(Loc
,
6224 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6225 Attribute_Name
=> Name_Max
,
6226 Expressions
=> New_List
(
6227 Make_Integer_Literal
(Loc
, 0),
6230 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
6232 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
6234 -- If the access type is associated with a simple storage pool
6235 -- object, then attempt to locate the optional Storage_Size
6236 -- function of the simple storage pool type. If not found,
6237 -- then the result will default to zero.
6239 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
6240 Name_Simple_Storage_Pool_Type
))
6243 Pool_Type
: constant Entity_Id
:=
6244 Base_Type
(Etype
(Entity
(N
)));
6247 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
6248 while Present
(Alloc_Op
) loop
6249 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
6250 and then Present
(First_Formal
(Alloc_Op
))
6251 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
6256 Alloc_Op
:= Homonym
(Alloc_Op
);
6260 -- In the normal Storage_Pool case, retrieve the primitive
6261 -- function associated with the pool type.
6266 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
6267 Attribute_Name
(N
));
6270 -- If Storage_Size wasn't found (can only occur in the simple
6271 -- storage pool case), then simply use zero for the result.
6273 if not Present
(Alloc_Op
) then
6274 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6276 -- Otherwise, rewrite the allocator as a call to pool type's
6277 -- Storage_Size function.
6282 Make_Function_Call
(Loc
,
6284 New_Occurrence_Of
(Alloc_Op
, Loc
),
6286 Parameter_Associations
=> New_List
(
6288 (Associated_Storage_Pool
6289 (Root_Type
(Ptyp
)), Loc
)))));
6293 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6296 Analyze_And_Resolve
(N
, Typ
);
6298 -- For tasks, we retrieve the size directly from the TCB. The
6299 -- size may depend on a discriminant of the type, and therefore
6300 -- can be a per-object expression, so type-level information is
6301 -- not sufficient in general. There are four cases to consider:
6303 -- a) If the attribute appears within a task body, the designated
6304 -- TCB is obtained by a call to Self.
6306 -- b) If the prefix of the attribute is the name of a task object,
6307 -- the designated TCB is the one stored in the corresponding record.
6309 -- c) If the prefix is a task type, the size is obtained from the
6310 -- size variable created for each task type
6312 -- d) If no Storage_Size was specified for the type, there is no
6313 -- size variable, and the value is a system-specific default.
6316 if In_Open_Scopes
(Ptyp
) then
6318 -- Storage_Size (Self)
6322 Make_Function_Call
(Loc
,
6324 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6325 Parameter_Associations
=>
6327 Make_Function_Call
(Loc
,
6329 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6331 elsif not Is_Entity_Name
(Pref
)
6332 or else not Is_Type
(Entity
(Pref
))
6334 -- Storage_Size (Rec (Obj).Size)
6338 Make_Function_Call
(Loc
,
6340 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6341 Parameter_Associations
=>
6343 Make_Selected_Component
(Loc
,
6345 Unchecked_Convert_To
(
6346 Corresponding_Record_Type
(Ptyp
),
6347 New_Copy_Tree
(Pref
)),
6349 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6351 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6353 -- Static Storage_Size pragma given for type: retrieve value
6354 -- from its allocated storage variable.
6358 Make_Function_Call
(Loc
,
6359 Name
=> New_Occurrence_Of
(
6360 RTE
(RE_Adjust_Storage_Size
), Loc
),
6361 Parameter_Associations
=>
6364 Storage_Size_Variable
(Ptyp
), Loc
)))));
6366 -- Get system default
6370 Make_Function_Call
(Loc
,
6373 RTE
(RE_Default_Stack_Size
), Loc
))));
6376 Analyze_And_Resolve
(N
, Typ
);
6384 when Attribute_Stream_Size
=>
6386 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6387 Analyze_And_Resolve
(N
, Typ
);
6393 -- 1. Deal with enumeration types with holes.
6394 -- 2. For floating-point, generate call to attribute function.
6395 -- 3. For other cases, deal with constraint checking.
6397 when Attribute_Succ
=> Succ
: declare
6398 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6401 -- For enumeration types with non-standard representations, we
6402 -- expand typ'Succ (x) into
6404 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6406 -- If the representation is contiguous, we compute instead
6407 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6409 if Is_Enumeration_Type
(Ptyp
)
6410 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6412 if Has_Contiguous_Rep
(Etyp
) then
6414 Unchecked_Convert_To
(Ptyp
,
6417 Make_Integer_Literal
(Loc
,
6418 Enumeration_Rep
(First_Literal
(Ptyp
))),
6420 Make_Function_Call
(Loc
,
6423 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6425 Parameter_Associations
=>
6427 Unchecked_Convert_To
(Ptyp
,
6430 Unchecked_Convert_To
(Standard_Integer
,
6431 Relocate_Node
(First
(Exprs
))),
6433 Make_Integer_Literal
(Loc
, 1))),
6434 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
6436 -- Add Boolean parameter True, to request program errror if
6437 -- we have a bad representation on our hands. Add False if
6438 -- checks are suppressed.
6440 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6442 Make_Indexed_Component
(Loc
,
6445 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6446 Expressions
=> New_List
(
6449 Make_Function_Call
(Loc
,
6452 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6453 Parameter_Associations
=> Exprs
),
6454 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6457 Analyze_And_Resolve
(N
, Typ
);
6459 -- For floating-point, we transform 'Succ into a call to the Succ
6460 -- floating-point attribute function in Fat_xxx (xxx is root type)
6462 elsif Is_Floating_Point_Type
(Ptyp
) then
6463 Expand_Fpt_Attribute_R
(N
);
6464 Analyze_And_Resolve
(N
, Typ
);
6466 -- For modular types, nothing to do (no overflow, since wraps)
6468 elsif Is_Modular_Integer_Type
(Ptyp
) then
6471 -- For other types, if argument is marked as needing a range check or
6472 -- overflow checking is enabled, we must generate a check.
6474 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6475 or else Do_Range_Check
(First
(Exprs
))
6477 Set_Do_Range_Check
(First
(Exprs
), False);
6478 Expand_Pred_Succ_Attribute
(N
);
6486 -- Transforms X'Tag into a direct reference to the tag of X
6488 when Attribute_Tag
=> Tag
: declare
6490 Prefix_Is_Type
: Boolean;
6493 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6494 Ttyp
:= Entity
(Pref
);
6495 Prefix_Is_Type
:= True;
6498 Prefix_Is_Type
:= False;
6501 if Is_Class_Wide_Type
(Ttyp
) then
6502 Ttyp
:= Root_Type
(Ttyp
);
6505 Ttyp
:= Underlying_Type
(Ttyp
);
6507 -- Ada 2005: The type may be a synchronized tagged type, in which
6508 -- case the tag information is stored in the corresponding record.
6510 if Is_Concurrent_Type
(Ttyp
) then
6511 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6514 if Prefix_Is_Type
then
6516 -- For VMs we leave the type attribute unexpanded because
6517 -- there's not a dispatching table to reference.
6519 if Tagged_Type_Expansion
then
6521 Unchecked_Convert_To
(RTE
(RE_Tag
),
6523 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6524 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6527 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6528 -- references the primary tag of the actual object. If 'Tag is
6529 -- applied to class-wide interface objects we generate code that
6530 -- displaces "this" to reference the base of the object.
6532 elsif Comes_From_Source
(N
)
6533 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6534 and then Is_Interface
(Underlying_Type
(Etype
(Prefix
(N
))))
6537 -- (To_Tag_Ptr (Prefix'Address)).all
6539 -- Note that Prefix'Address is recursively expanded into a call
6540 -- to Base_Address (Obj.Tag)
6542 -- Not needed for VM targets, since all handled by the VM
6544 if Tagged_Type_Expansion
then
6546 Make_Explicit_Dereference
(Loc
,
6547 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6548 Make_Attribute_Reference
(Loc
,
6549 Prefix
=> Relocate_Node
(Pref
),
6550 Attribute_Name
=> Name_Address
))));
6551 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6556 Make_Selected_Component
(Loc
,
6557 Prefix
=> Relocate_Node
(Pref
),
6559 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6560 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6568 -- Transforms 'Terminated attribute into a call to Terminated function
6570 when Attribute_Terminated
=> Terminated
: begin
6572 -- The prefix of Terminated is of a task interface class-wide type.
6574 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6576 if Ada_Version
>= Ada_2005
6577 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6578 and then Is_Interface
(Ptyp
)
6579 and then Is_Task_Interface
(Ptyp
)
6582 Make_Function_Call
(Loc
,
6584 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6585 Parameter_Associations
=> New_List
(
6586 Make_Unchecked_Type_Conversion
(Loc
,
6588 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6589 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
6591 elsif Restricted_Profile
then
6593 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6597 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6600 Analyze_And_Resolve
(N
, Standard_Boolean
);
6607 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6608 -- unchecked conversion from (integral) type of X to type address. If
6609 -- the To_Address is a static expression, the transformed expression
6610 -- also needs to be static, because we do some legality checks (e.g.
6611 -- for Thread_Local_Storage) after this transformation.
6614 | Attribute_To_Address
6616 To_Address
: declare
6617 Is_Static
: constant Boolean := Is_Static_Expression
(N
);
6621 Unchecked_Convert_To
(RTE
(RE_Address
),
6622 Relocate_Node
(First
(Exprs
))));
6623 Set_Is_Static_Expression
(N
, Is_Static
);
6625 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6632 when Attribute_To_Any
=> To_Any
: declare
6633 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6634 Decls
: constant List_Id
:= New_List
;
6640 Relocate_Node
(First
(Exprs
))), Decls
));
6641 Insert_Actions
(N
, Decls
);
6642 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6649 -- Transforms 'Truncation into a call to the floating-point attribute
6650 -- function Truncation in Fat_xxx (where xxx is the root type).
6651 -- Expansion is avoided for cases the back end can handle directly.
6653 when Attribute_Truncation
=>
6654 if not Is_Inline_Floating_Point_Attribute
(N
) then
6655 Expand_Fpt_Attribute_R
(N
);
6662 when Attribute_TypeCode
=> TypeCode
: declare
6663 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6664 Decls
: constant List_Id
:= New_List
;
6666 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
6667 Insert_Actions
(N
, Decls
);
6668 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6671 -----------------------
6672 -- Unbiased_Rounding --
6673 -----------------------
6675 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6676 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6677 -- root type). Expansion is avoided for cases the back end can handle
6680 when Attribute_Unbiased_Rounding
=>
6681 if not Is_Inline_Floating_Point_Attribute
(N
) then
6682 Expand_Fpt_Attribute_R
(N
);
6689 when Attribute_Update
=>
6690 Expand_Update_Attribute
(N
);
6696 -- The processing for VADS_Size is shared with Size
6702 -- For enumeration types with a standard representation, and for all
6703 -- other types, Val is handled by the back end. For enumeration types
6704 -- with a non-standard representation we use the _Pos_To_Rep array that
6705 -- was created when the type was frozen.
6707 when Attribute_Val
=> Val
: declare
6708 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
6711 if Is_Enumeration_Type
(Etyp
)
6712 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6714 if Has_Contiguous_Rep
(Etyp
) then
6716 Rep_Node
: constant Node_Id
:=
6717 Unchecked_Convert_To
(Etyp
,
6720 Make_Integer_Literal
(Loc
,
6721 Enumeration_Rep
(First_Literal
(Etyp
))),
6723 (Convert_To
(Standard_Integer
,
6724 Relocate_Node
(First
(Exprs
))))));
6728 Unchecked_Convert_To
(Etyp
,
6731 Make_Integer_Literal
(Loc
,
6732 Enumeration_Rep
(First_Literal
(Etyp
))),
6734 Make_Function_Call
(Loc
,
6737 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6738 Parameter_Associations
=> New_List
(
6740 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
6745 Make_Indexed_Component
(Loc
,
6746 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
6747 Expressions
=> New_List
(
6748 Convert_To
(Standard_Integer
,
6749 Relocate_Node
(First
(Exprs
))))));
6752 Analyze_And_Resolve
(N
, Typ
);
6754 -- If the argument is marked as requiring a range check then generate
6757 elsif Do_Range_Check
(First
(Exprs
)) then
6758 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
6766 -- The code for valid is dependent on the particular types involved.
6767 -- See separate sections below for the generated code in each case.
6769 when Attribute_Valid
=> Valid
: declare
6770 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
6772 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
6773 -- Save the validity checking mode. We always turn off validity
6774 -- checking during process of 'Valid since this is one place
6775 -- where we do not want the implicit validity checks to interfere
6776 -- with the explicit validity check that the programmer is doing.
6778 function Make_Range_Test
return Node_Id
;
6779 -- Build the code for a range test of the form
6780 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6782 ---------------------
6783 -- Make_Range_Test --
6784 ---------------------
6786 function Make_Range_Test
return Node_Id
is
6790 -- The prefix of attribute 'Valid should always denote an object
6791 -- reference. The reference is either coming directly from source
6792 -- or is produced by validity check expansion. The object may be
6793 -- wrapped in a conversion in which case the call to Unqual_Conv
6796 -- If the prefix denotes a variable which captures the value of
6797 -- an object for validation purposes, use the variable in the
6798 -- range test. This ensures that no extra copies or extra reads
6799 -- are produced as part of the test. Generate:
6801 -- Temp : ... := Object;
6802 -- if not Temp in ... then
6804 if Is_Validation_Variable_Reference
(Pref
) then
6805 Temp
:= New_Occurrence_Of
(Entity
(Unqual_Conv
(Pref
)), Loc
);
6807 -- Otherwise the prefix is either a source object or a constant
6808 -- produced by validity check expansion. Generate:
6810 -- Temp : constant ... := Pref;
6811 -- if not Temp in ... then
6814 Temp
:= Duplicate_Subexpr
(Pref
);
6819 Left_Opnd
=> Unchecked_Convert_To
(Btyp
, Temp
),
6823 Unchecked_Convert_To
(Btyp
,
6824 Make_Attribute_Reference
(Loc
,
6825 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6826 Attribute_Name
=> Name_First
)),
6828 Unchecked_Convert_To
(Btyp
,
6829 Make_Attribute_Reference
(Loc
,
6830 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6831 Attribute_Name
=> Name_Last
))));
6832 end Make_Range_Test
;
6838 -- Start of processing for Attribute_Valid
6841 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6842 -- will be handled by the back-end directly.
6844 if CodePeer_Mode
and then Comes_From_Source
(N
) then
6848 -- Turn off validity checks. We do not want any implicit validity
6849 -- checks to intefere with the explicit check from the attribute
6851 Validity_Checks_On
:= False;
6853 -- Retrieve the base type. Handle the case where the base type is a
6854 -- private enumeration type.
6856 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
6857 Btyp
:= Full_View
(Btyp
);
6860 -- Floating-point case. This case is handled by the Valid attribute
6861 -- code in the floating-point attribute run-time library.
6863 if Is_Floating_Point_Type
(Ptyp
) then
6864 Float_Valid
: declare
6868 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
6869 -- Return entity for Pkg.Nam
6871 --------------------
6872 -- Get_Fat_Entity --
6873 --------------------
6875 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
6876 Exp_Name
: constant Node_Id
:=
6877 Make_Selected_Component
(Loc
,
6878 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
6879 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
6881 Find_Selected_Component
(Exp_Name
);
6882 return Entity
(Exp_Name
);
6885 -- Start of processing for Float_Valid
6888 -- The C and AAMP back-ends handle Valid for fpt types
6890 if Modify_Tree_For_C
or else Float_Rep
(Btyp
) = AAMP
then
6891 Analyze_And_Resolve
(Pref
, Ptyp
);
6892 Set_Etype
(N
, Standard_Boolean
);
6896 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6898 -- If the prefix is a reverse SSO component, or is possibly
6899 -- unaligned, first create a temporary copy that is in
6900 -- native SSO, and properly aligned. Make it Volatile to
6901 -- prevent folding in the back-end. Note that we use an
6902 -- intermediate constrained string type to initialize the
6903 -- temporary, as the value at hand might be invalid, and in
6904 -- that case it cannot be copied using a floating point
6907 if In_Reverse_Storage_Order_Object
(Pref
)
6908 or else Is_Possibly_Unaligned_Object
(Pref
)
6911 Temp
: constant Entity_Id
:=
6912 Make_Temporary
(Loc
, 'F');
6914 Fat_S
: constant Entity_Id
:=
6915 Get_Fat_Entity
(Name_S
);
6916 -- Constrained string subtype of appropriate size
6918 Fat_P
: constant Entity_Id
:=
6919 Get_Fat_Entity
(Name_P
);
6922 Decl
: constant Node_Id
:=
6923 Make_Object_Declaration
(Loc
,
6924 Defining_Identifier
=> Temp
,
6925 Aliased_Present
=> True,
6926 Object_Definition
=>
6927 New_Occurrence_Of
(Ptyp
, Loc
));
6930 Set_Aspect_Specifications
(Decl
, New_List
(
6931 Make_Aspect_Specification
(Loc
,
6933 Make_Identifier
(Loc
, Name_Volatile
))));
6939 Make_Assignment_Statement
(Loc
,
6941 Make_Explicit_Dereference
(Loc
,
6943 Unchecked_Convert_To
(Fat_P
,
6944 Make_Attribute_Reference
(Loc
,
6946 New_Occurrence_Of
(Temp
, Loc
),
6948 Name_Unrestricted_Access
))),
6950 Unchecked_Convert_To
(Fat_S
,
6951 Relocate_Node
(Pref
)))),
6953 Suppress
=> All_Checks
);
6955 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
6959 -- We now have an object of the proper endianness and
6960 -- alignment, and can construct a Valid attribute.
6962 -- We make sure the prefix of this valid attribute is
6963 -- marked as not coming from source, to avoid losing
6964 -- warnings from 'Valid looking like a possible update.
6966 Set_Comes_From_Source
(Pref
, False);
6968 Expand_Fpt_Attribute
6969 (N
, Pkg
, Name_Valid
,
6971 Make_Attribute_Reference
(Loc
,
6972 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6973 Attribute_Name
=> Name_Unrestricted_Access
)));
6976 -- One more task, we still need a range check. Required
6977 -- only if we have a constraint, since the Valid routine
6978 -- catches infinities properly (infinities are never valid).
6980 -- The way we do the range check is simply to create the
6981 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6983 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
6986 Left_Opnd
=> Relocate_Node
(N
),
6989 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
6990 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6994 -- Enumeration type with holes
6996 -- For enumeration types with holes, the Pos value constructed by
6997 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6998 -- second argument of False returns minus one for an invalid value,
6999 -- and the non-negative pos value for a valid value, so the
7000 -- expansion of X'Valid is simply:
7002 -- type(X)'Pos (X) >= 0
7004 -- We can't quite generate it that way because of the requirement
7005 -- for the non-standard second argument of False in the resulting
7006 -- rep_to_pos call, so we have to explicitly create:
7008 -- _rep_to_pos (X, False) >= 0
7010 -- If we have an enumeration subtype, we also check that the
7011 -- value is in range:
7013 -- _rep_to_pos (X, False) >= 0
7015 -- (X >= type(X)'First and then type(X)'Last <= X)
7017 elsif Is_Enumeration_Type
(Ptyp
)
7018 and then Present
(Enum_Pos_To_Rep
(Btyp
))
7023 Make_Function_Call
(Loc
,
7025 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
7026 Parameter_Associations
=> New_List
(
7028 New_Occurrence_Of
(Standard_False
, Loc
))),
7029 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
7033 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
7035 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
7037 -- The call to Make_Range_Test will create declarations
7038 -- that need a proper insertion point, but Pref is now
7039 -- attached to a node with no ancestor. Attach to tree
7040 -- even if it is to be rewritten below.
7042 Set_Parent
(Tst
, Parent
(N
));
7046 Left_Opnd
=> Make_Range_Test
,
7052 -- Fortran convention booleans
7054 -- For the very special case of Fortran convention booleans, the
7055 -- value is always valid, since it is an integer with the semantics
7056 -- that non-zero is true, and any value is permissible.
7058 elsif Is_Boolean_Type
(Ptyp
)
7059 and then Convention
(Ptyp
) = Convention_Fortran
7061 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
7063 -- For biased representations, we will be doing an unchecked
7064 -- conversion without unbiasing the result. That means that the range
7065 -- test has to take this into account, and the proper form of the
7068 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
7070 elsif Has_Biased_Representation
(Ptyp
) then
7071 Btyp
:= RTE
(RE_Unsigned_32
);
7075 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
7077 Unchecked_Convert_To
(Btyp
,
7078 Make_Attribute_Reference
(Loc
,
7079 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7080 Attribute_Name
=> Name_Range_Length
))));
7082 -- For all other scalar types, what we want logically is a
7085 -- X in type(X)'First .. type(X)'Last
7087 -- But that's precisely what won't work because of possible
7088 -- unwanted optimization (and indeed the basic motivation for
7089 -- the Valid attribute is exactly that this test does not work).
7090 -- What will work is:
7092 -- Btyp!(X) >= Btyp!(type(X)'First)
7094 -- Btyp!(X) <= Btyp!(type(X)'Last)
7096 -- where Btyp is an integer type large enough to cover the full
7097 -- range of possible stored values (i.e. it is chosen on the basis
7098 -- of the size of the type, not the range of the values). We write
7099 -- this as two tests, rather than a range check, so that static
7100 -- evaluation will easily remove either or both of the checks if
7101 -- they can be -statically determined to be true (this happens
7102 -- when the type of X is static and the range extends to the full
7103 -- range of stored values).
7105 -- Unsigned types. Note: it is safe to consider only whether the
7106 -- subtype is unsigned, since we will in that case be doing all
7107 -- unsigned comparisons based on the subtype range. Since we use the
7108 -- actual subtype object size, this is appropriate.
7110 -- For example, if we have
7112 -- subtype x is integer range 1 .. 200;
7113 -- for x'Object_Size use 8;
7115 -- Now the base type is signed, but objects of this type are bits
7116 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7117 -- correct, even though a value greater than 127 looks signed to a
7118 -- signed comparison.
7120 elsif Is_Unsigned_Type
(Ptyp
) then
7121 if Esize
(Ptyp
) <= 32 then
7122 Btyp
:= RTE
(RE_Unsigned_32
);
7124 Btyp
:= RTE
(RE_Unsigned_64
);
7127 Rewrite
(N
, Make_Range_Test
);
7132 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
7133 Btyp
:= Standard_Integer
;
7135 Btyp
:= Universal_Integer
;
7138 Rewrite
(N
, Make_Range_Test
);
7141 -- If a predicate is present, then we do the predicate test, even if
7142 -- within the predicate function (infinite recursion is warned about
7143 -- in Sem_Attr in that case).
7146 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
7149 if Present
(Pred_Func
) then
7152 Left_Opnd
=> Relocate_Node
(N
),
7153 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
7157 Analyze_And_Resolve
(N
, Standard_Boolean
);
7158 Validity_Checks_On
:= Save_Validity_Checks_On
;
7165 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
7166 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7167 Comp_Typ
: Entity_Id
;
7171 -- Assume that the prefix does not need validation
7175 -- Attribute 'Valid_Scalars is not supported on private tagged types
7177 if Is_Private_Type
(Ptyp
) and then Is_Tagged_Type
(Ptyp
) then
7180 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7183 elsif not Scalar_Part_Present
(Val_Typ
) then
7186 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7187 -- validated type is a scalar type. Generate:
7189 -- Val_Typ (Pref)'Valid
7191 elsif Is_Scalar_Type
(Val_Typ
) then
7193 Make_Attribute_Reference
(Loc
,
7195 Unchecked_Convert_To
(Val_Typ
, New_Copy_Tree
(Pref
)),
7196 Attribute_Name
=> Name_Valid
);
7198 -- Validate the scalar components of an array by iterating over all
7199 -- dimensions of the array while checking individual components.
7201 elsif Is_Array_Type
(Val_Typ
) then
7202 Comp_Typ
:= Validated_View
(Component_Type
(Val_Typ
));
7204 if Scalar_Part_Present
(Comp_Typ
) then
7206 Make_Function_Call
(Loc
,
7209 (Build_Array_VS_Func
7212 Array_Typ
=> Val_Typ
,
7213 Comp_Typ
=> Comp_Typ
),
7215 Parameter_Associations
=> New_List
(Pref
));
7218 -- Validate the scalar components, discriminants of a record type by
7219 -- examining the structure of a record type.
7221 elsif Is_Record_Type
(Val_Typ
) then
7223 Make_Function_Call
(Loc
,
7226 (Build_Record_VS_Func
7229 Rec_Typ
=> Val_Typ
),
7231 Parameter_Associations
=> New_List
(Pref
));
7234 -- Default the attribute to True when the type of the prefix does not
7238 Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
7242 Analyze_And_Resolve
(N
, Standard_Boolean
);
7243 Set_Is_Static_Expression
(N
, False);
7250 -- Value attribute is handled in separate unit Exp_Imgv
7252 when Attribute_Value
=>
7253 Exp_Imgv
.Expand_Value_Attribute
(N
);
7259 -- The processing for Value_Size shares the processing for Size
7265 -- The processing for Version shares the processing for Body_Version
7271 -- Wide_Image attribute is handled in separate unit Exp_Imgv
7273 when Attribute_Wide_Image
=>
7274 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7275 -- back-end knows how to handle this attribute directly.
7277 if CodePeer_Mode
then
7281 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
7283 ---------------------
7284 -- Wide_Wide_Image --
7285 ---------------------
7287 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7289 when Attribute_Wide_Wide_Image
=>
7290 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7291 -- back-end knows how to handle this attribute directly.
7293 if CodePeer_Mode
then
7297 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7303 -- We expand typ'Wide_Value (X) into
7306 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7308 -- Wide_String_To_String is a runtime function that converts its wide
7309 -- string argument to String, converting any non-translatable characters
7310 -- into appropriate escape sequences. This preserves the required
7311 -- semantics of Wide_Value in all cases, and results in a very simple
7312 -- implementation approach.
7314 -- Note: for this approach to be fully standard compliant for the cases
7315 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7316 -- method must cover the entire character range (e.g. UTF-8). But that
7317 -- is a reasonable requirement when dealing with encoded character
7318 -- sequences. Presumably if one of the restrictive encoding mechanisms
7319 -- is in use such as Shift-JIS, then characters that cannot be
7320 -- represented using this encoding will not appear in any case.
7322 when Attribute_Wide_Value
=>
7324 Make_Attribute_Reference
(Loc
,
7326 Attribute_Name
=> Name_Value
,
7328 Expressions
=> New_List
(
7329 Make_Function_Call
(Loc
,
7331 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7333 Parameter_Associations
=> New_List
(
7334 Relocate_Node
(First
(Exprs
)),
7335 Make_Integer_Literal
(Loc
,
7336 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7338 Analyze_And_Resolve
(N
, Typ
);
7340 ---------------------
7341 -- Wide_Wide_Value --
7342 ---------------------
7344 -- We expand typ'Wide_Value_Value (X) into
7347 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7349 -- Wide_Wide_String_To_String is a runtime function that converts its
7350 -- wide string argument to String, converting any non-translatable
7351 -- characters into appropriate escape sequences. This preserves the
7352 -- required semantics of Wide_Wide_Value in all cases, and results in a
7353 -- very simple implementation approach.
7355 -- It's not quite right where typ = Wide_Wide_Character, because the
7356 -- encoding method may not cover the whole character type ???
7358 when Attribute_Wide_Wide_Value
=>
7360 Make_Attribute_Reference
(Loc
,
7362 Attribute_Name
=> Name_Value
,
7364 Expressions
=> New_List
(
7365 Make_Function_Call
(Loc
,
7368 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7370 Parameter_Associations
=> New_List
(
7371 Relocate_Node
(First
(Exprs
)),
7372 Make_Integer_Literal
(Loc
,
7373 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7375 Analyze_And_Resolve
(N
, Typ
);
7377 ---------------------
7378 -- Wide_Wide_Width --
7379 ---------------------
7381 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7383 when Attribute_Wide_Wide_Width
=>
7384 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7390 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7392 when Attribute_Wide_Width
=>
7393 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7399 -- Width attribute is handled in separate unit Exp_Imgv
7401 when Attribute_Width
=>
7402 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7408 when Attribute_Write
=> Write
: declare
7409 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7410 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7418 -- If no underlying type, we have an error that will be diagnosed
7419 -- elsewhere, so here we just completely ignore the expansion.
7425 -- Stream operations can appear in user code even if the restriction
7426 -- No_Streams is active (for example, when instantiating a predefined
7427 -- container). In that case rewrite the attribute as a Raise to
7428 -- prevent any run-time use.
7430 if Restriction_Active
(No_Streams
) then
7432 Make_Raise_Program_Error
(Sloc
(N
),
7433 Reason
=> PE_Stream_Operation_Not_Allowed
));
7434 Set_Etype
(N
, U_Type
);
7438 -- The simple case, if there is a TSS for Write, just call it
7440 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7442 if Present
(Pname
) then
7446 -- If there is a Stream_Convert pragma, use it, we rewrite
7448 -- sourcetyp'Output (stream, Item)
7452 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7454 -- where strmwrite is the given Write function that converts an
7455 -- argument of type sourcetyp or a type acctyp, from which it is
7456 -- derived to type strmtyp. The conversion to acttyp is required
7457 -- for the derived case.
7459 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7461 if Present
(Prag
) then
7463 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7464 Wfunc
:= Entity
(Expression
(Arg3
));
7467 Make_Attribute_Reference
(Loc
,
7468 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7469 Attribute_Name
=> Name_Output
,
7470 Expressions
=> New_List
(
7471 Relocate_Node
(First
(Exprs
)),
7472 Make_Function_Call
(Loc
,
7473 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7474 Parameter_Associations
=> New_List
(
7475 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7476 Relocate_Node
(Next
(First
(Exprs
)))))))));
7481 -- For elementary types, we call the W_xxx routine directly
7483 elsif Is_Elementary_Type
(U_Type
) then
7484 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7490 elsif Is_Array_Type
(U_Type
) then
7491 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7492 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
7494 -- Tagged type case, use the primitive Write function. Note that
7495 -- this will dispatch in the class-wide case which is what we want
7497 elsif Is_Tagged_Type
(U_Type
) then
7498 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7500 -- All other record type cases, including protected records.
7501 -- The latter only arise for expander generated code for
7502 -- handling shared passive partition access.
7506 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7508 -- Ada 2005 (AI-216): Program_Error is raised when executing
7509 -- the default implementation of the Write attribute of an
7510 -- Unchecked_Union type. However, if the 'Write reference is
7511 -- within the generated Output stream procedure, Write outputs
7512 -- the components, and the default values of the discriminant
7513 -- are streamed by the Output procedure itself. If there are
7514 -- no default values this is also erroneous.
7516 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
7517 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7518 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
7519 or else No
(Discriminant_Default_Value
7520 (First_Discriminant
(U_Type
)))
7523 Make_Raise_Program_Error
(Loc
,
7524 Reason
=> PE_Unchecked_Union_Restriction
));
7525 Set_Etype
(N
, U_Type
);
7530 if Has_Discriminants
(U_Type
)
7532 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
7534 Build_Mutable_Record_Write_Procedure
7535 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7537 Build_Record_Write_Procedure
7538 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7541 Insert_Action
(N
, Decl
);
7545 -- If we fall through, Pname is the procedure to be called
7547 Rewrite_Stream_Proc_Call
(Pname
);
7550 -- Component_Size is handled by the back end, unless the component size
7551 -- is known at compile time, which is always true in the packed array
7552 -- case. It is important that the packed array case is handled in the
7553 -- front end (see Eval_Attribute) since the back end would otherwise get
7554 -- confused by the equivalent packed array type.
7556 when Attribute_Component_Size
=>
7559 -- The following attributes are handled by the back end (except that
7560 -- static cases have already been evaluated during semantic processing,
7561 -- but in any case the back end should not count on this).
7563 -- The back end also handles the non-class-wide cases of Size
7565 when Attribute_Bit_Order
7566 | Attribute_Code_Address
7567 | Attribute_Definite
7569 | Attribute_Null_Parameter
7570 | Attribute_Passed_By_Reference
7571 | Attribute_Pool_Address
7572 | Attribute_Scalar_Storage_Order
7576 -- The following attributes are also handled by the back end, but return
7577 -- a universal integer result, so may need a conversion for checking
7578 -- that the result is in range.
7581 | Attribute_Max_Alignment_For_Allocation
7583 Apply_Universal_Integer_Attribute_Checks
(N
);
7585 -- The following attributes should not appear at this stage, since they
7586 -- have already been handled by the analyzer (and properly rewritten
7587 -- with corresponding values or entities to represent the right values)
7589 when Attribute_Abort_Signal
7590 | Attribute_Address_Size
7591 | Attribute_Atomic_Always_Lock_Free
7594 | Attribute_Compiler_Version
7595 | Attribute_Default_Bit_Order
7596 | Attribute_Default_Scalar_Storage_Order
7603 | Attribute_Fast_Math
7604 | Attribute_First_Valid
7605 | Attribute_Has_Access_Values
7606 | Attribute_Has_Discriminants
7607 | Attribute_Has_Tagged_Values
7609 | Attribute_Last_Valid
7610 | Attribute_Library_Level
7611 | Attribute_Lock_Free
7612 | Attribute_Machine_Emax
7613 | Attribute_Machine_Emin
7614 | Attribute_Machine_Mantissa
7615 | Attribute_Machine_Overflows
7616 | Attribute_Machine_Radix
7617 | Attribute_Machine_Rounds
7618 | Attribute_Maximum_Alignment
7619 | Attribute_Model_Emin
7620 | Attribute_Model_Epsilon
7621 | Attribute_Model_Mantissa
7622 | Attribute_Model_Small
7624 | Attribute_Partition_ID
7626 | Attribute_Restriction_Set
7627 | Attribute_Safe_Emax
7628 | Attribute_Safe_First
7629 | Attribute_Safe_Large
7630 | Attribute_Safe_Last
7631 | Attribute_Safe_Small
7633 | Attribute_Signed_Zeros
7635 | Attribute_Storage_Unit
7636 | Attribute_Stub_Type
7637 | Attribute_System_Allocator_Alignment
7638 | Attribute_Target_Name
7639 | Attribute_Type_Class
7640 | Attribute_Type_Key
7641 | Attribute_Unconstrained_Array
7642 | Attribute_Universal_Literal_String
7643 | Attribute_Wchar_T_Size
7644 | Attribute_Word_Size
7646 raise Program_Error
;
7648 -- The Asm_Input and Asm_Output attributes are not expanded at this
7649 -- stage, but will be eliminated in the expansion of the Asm call, see
7650 -- Exp_Intr for details. So the back end will never see these either.
7652 when Attribute_Asm_Input
7653 | Attribute_Asm_Output
7658 -- Note: as mentioned earlier, individual sections of the above case
7659 -- statement assume there is no code after the case statement, and are
7660 -- legitimately allowed to execute return statements if they have nothing
7661 -- more to do, so DO NOT add code at this point.
7664 when RE_Not_Available
=>
7666 end Expand_N_Attribute_Reference
;
7668 --------------------------------
7669 -- Expand_Pred_Succ_Attribute --
7670 --------------------------------
7672 -- For typ'Pred (exp), we generate the check
7674 -- [constraint_error when exp = typ'Base'First]
7676 -- Similarly, for typ'Succ (exp), we generate the check
7678 -- [constraint_error when exp = typ'Base'Last]
7680 -- These checks are not generated for modular types, since the proper
7681 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7682 -- We also suppress these checks if we are the right side of an assignment
7683 -- statement or the expression of an object declaration, where the flag
7684 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7686 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
7687 Loc
: constant Source_Ptr
:= Sloc
(N
);
7688 P
: constant Node_Id
:= Parent
(N
);
7692 if Attribute_Name
(N
) = Name_Pred
then
7698 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
7699 or else not Suppress_Assignment_Checks
(P
)
7702 Make_Raise_Constraint_Error
(Loc
,
7706 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
7708 Make_Attribute_Reference
(Loc
,
7710 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
7711 Attribute_Name
=> Cnam
)),
7712 Reason
=> CE_Overflow_Check_Failed
));
7714 end Expand_Pred_Succ_Attribute
;
7716 -----------------------------
7717 -- Expand_Update_Attribute --
7718 -----------------------------
7720 procedure Expand_Update_Attribute
(N
: Node_Id
) is
7721 procedure Process_Component_Or_Element_Update
7726 -- Generate the statements necessary to update a single component or an
7727 -- element of the prefix. The code is inserted before the attribute N.
7728 -- Temp denotes the entity of the anonymous object created to reflect
7729 -- the changes in values. Comp is the component/index expression to be
7730 -- updated. Expr is an expression yielding the new value of Comp. Typ
7731 -- is the type of the prefix of attribute Update.
7733 procedure Process_Range_Update
7738 -- Generate the statements necessary to update a slice of the prefix.
7739 -- The code is inserted before the attribute N. Temp denotes the entity
7740 -- of the anonymous object created to reflect the changes in values.
7741 -- Comp is range of the slice to be updated. Expr is an expression
7742 -- yielding the new value of Comp. Typ is the type of the prefix of
7743 -- attribute Update.
7745 -----------------------------------------
7746 -- Process_Component_Or_Element_Update --
7747 -----------------------------------------
7749 procedure Process_Component_Or_Element_Update
7755 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7760 -- An array element may be modified by the following relations
7761 -- depending on the number of dimensions:
7763 -- 1 => Expr -- one dimensional update
7764 -- (1, ..., N) => Expr -- multi dimensional update
7766 -- The above forms are converted in assignment statements where the
7767 -- left hand side is an indexed component:
7769 -- Temp (1) := Expr; -- one dimensional update
7770 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7772 if Is_Array_Type
(Typ
) then
7774 -- The index expressions of a multi dimensional array update
7775 -- appear as an aggregate.
7777 if Nkind
(Comp
) = N_Aggregate
then
7778 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
7780 Exprs
:= New_List
(Relocate_Node
(Comp
));
7784 Make_Indexed_Component
(Loc
,
7785 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7786 Expressions
=> Exprs
);
7788 -- A record component update appears in the following form:
7792 -- The above relation is transformed into an assignment statement
7793 -- where the left hand side is a selected component:
7795 -- Temp.Comp := Expr;
7797 else pragma Assert
(Is_Record_Type
(Typ
));
7799 Make_Selected_Component
(Loc
,
7800 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7801 Selector_Name
=> Relocate_Node
(Comp
));
7805 Make_Assignment_Statement
(Loc
,
7807 Expression
=> Relocate_Node
(Expr
)));
7808 end Process_Component_Or_Element_Update
;
7810 --------------------------
7811 -- Process_Range_Update --
7812 --------------------------
7814 procedure Process_Range_Update
7820 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
7821 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7825 -- A range update appears as
7827 -- (Low .. High => Expr)
7829 -- The above construct is transformed into a loop that iterates over
7830 -- the given range and modifies the corresponding array values to the
7833 -- for Index in Low .. High loop
7834 -- Temp (<Index_Typ> (Index)) := Expr;
7837 Index
:= Make_Temporary
(Loc
, 'I');
7840 Make_Loop_Statement
(Loc
,
7842 Make_Iteration_Scheme
(Loc
,
7843 Loop_Parameter_Specification
=>
7844 Make_Loop_Parameter_Specification
(Loc
,
7845 Defining_Identifier
=> Index
,
7846 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
7848 Statements
=> New_List
(
7849 Make_Assignment_Statement
(Loc
,
7851 Make_Indexed_Component
(Loc
,
7852 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7853 Expressions
=> New_List
(
7854 Convert_To
(Index_Typ
,
7855 New_Occurrence_Of
(Index
, Loc
)))),
7856 Expression
=> Relocate_Node
(Expr
))),
7858 End_Label
=> Empty
));
7859 end Process_Range_Update
;
7863 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
7864 Loc
: constant Source_Ptr
:= Sloc
(N
);
7865 Pref
: constant Node_Id
:= Prefix
(N
);
7866 Typ
: constant Entity_Id
:= Etype
(Pref
);
7869 CW_Temp
: Entity_Id
;
7874 -- Start of processing for Expand_Update_Attribute
7877 -- Create the anonymous object to store the value of the prefix and
7878 -- capture subsequent changes in value.
7880 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
7882 -- Preserve the tag of the prefix by offering a specific view of the
7883 -- class-wide version of the prefix.
7885 if Is_Tagged_Type
(Typ
) then
7888 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7890 CW_Temp
:= Make_Temporary
(Loc
, 'T');
7891 CW_Typ
:= Class_Wide_Type
(Typ
);
7894 Make_Object_Declaration
(Loc
,
7895 Defining_Identifier
=> CW_Temp
,
7896 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
7898 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
7901 -- Temp : Typ renames Typ (CW_Temp);
7904 Make_Object_Renaming_Declaration
(Loc
,
7905 Defining_Identifier
=> Temp
,
7906 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
7908 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
7914 -- Temp : Typ := Pref;
7917 Make_Object_Declaration
(Loc
,
7918 Defining_Identifier
=> Temp
,
7919 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7920 Expression
=> Relocate_Node
(Pref
)));
7923 -- Process the update aggregate
7925 Assoc
:= First
(Component_Associations
(Aggr
));
7926 while Present
(Assoc
) loop
7927 Comp
:= First
(Choices
(Assoc
));
7928 Expr
:= Expression
(Assoc
);
7929 while Present
(Comp
) loop
7930 if Nkind
(Comp
) = N_Range
then
7931 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
7933 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
7942 -- The attribute is replaced by a reference to the anonymous object
7944 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7946 end Expand_Update_Attribute
;
7952 procedure Find_Fat_Info
7954 Fat_Type
: out Entity_Id
;
7955 Fat_Pkg
: out RE_Id
)
7957 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
7960 -- All we do is use the root type (historically this dealt with
7961 -- VAX-float .. to be cleaned up further later ???)
7965 if Fat_Type
= Standard_Short_Float
then
7966 Fat_Pkg
:= RE_Attr_Short_Float
;
7968 elsif Fat_Type
= Standard_Float
then
7969 Fat_Pkg
:= RE_Attr_Float
;
7971 elsif Fat_Type
= Standard_Long_Float
then
7972 Fat_Pkg
:= RE_Attr_Long_Float
;
7974 elsif Fat_Type
= Standard_Long_Long_Float
then
7975 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7977 -- Universal real (which is its own root type) is treated as being
7978 -- equivalent to Standard.Long_Long_Float, since it is defined to
7979 -- have the same precision as the longest Float type.
7981 elsif Fat_Type
= Universal_Real
then
7982 Fat_Type
:= Standard_Long_Long_Float
;
7983 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7986 raise Program_Error
;
7990 ----------------------------
7991 -- Find_Stream_Subprogram --
7992 ----------------------------
7994 function Find_Stream_Subprogram
7996 Nam
: TSS_Name_Type
) return Entity_Id
7998 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7999 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
8001 function Is_Available
(Entity
: RE_Id
) return Boolean;
8002 pragma Inline
(Is_Available
);
8003 -- Function to check whether the specified run-time call is available
8004 -- in the run time used. In the case of a configurable run time, it
8005 -- is normal that some subprograms are not there.
8007 -- I don't understand this routine at all, why is this not just a
8008 -- call to RTE_Available? And if for some reason we need a different
8009 -- routine with different semantics, why is not in Rtsfind ???
8015 function Is_Available
(Entity
: RE_Id
) return Boolean is
8017 -- Assume that the unit will always be available when using a
8018 -- "normal" (not configurable) run time.
8020 return not Configurable_Run_Time_Mode
or else RTE_Available
(Entity
);
8023 -- Start of processing for Find_Stream_Subprogram
8026 if Present
(Ent
) then
8030 -- Stream attributes for strings are expanded into library calls. The
8031 -- following checks are disabled when the run-time is not available or
8032 -- when compiling predefined types due to bootstrap issues. As a result,
8033 -- the compiler will generate in-place stream routines for string types
8034 -- that appear in GNAT's library, but will generate calls via rtsfind
8035 -- to library routines for user code.
8037 -- Note: In the case of using a configurable run time, it is very likely
8038 -- that stream routines for string types are not present (they require
8039 -- file system support). In this case, the specific stream routines for
8040 -- strings are not used, relying on the regular stream mechanism
8041 -- instead. That is why we include the test Is_Available when dealing
8042 -- with these cases.
8044 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
8045 -- Storage_Array as defined in package System.Storage_Elements
8047 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
8049 -- Case of No_Stream_Optimizations restriction active
8051 if Restriction_Active
(No_Stream_Optimizations
) then
8052 if Nam
= TSS_Stream_Input
8053 and then Is_Available
(RE_Storage_Array_Input
)
8055 return RTE
(RE_Storage_Array_Input
);
8057 elsif Nam
= TSS_Stream_Output
8058 and then Is_Available
(RE_Storage_Array_Output
)
8060 return RTE
(RE_Storage_Array_Output
);
8062 elsif Nam
= TSS_Stream_Read
8063 and then Is_Available
(RE_Storage_Array_Read
)
8065 return RTE
(RE_Storage_Array_Read
);
8067 elsif Nam
= TSS_Stream_Write
8068 and then Is_Available
(RE_Storage_Array_Write
)
8070 return RTE
(RE_Storage_Array_Write
);
8072 elsif Nam
/= TSS_Stream_Input
and then
8073 Nam
/= TSS_Stream_Output
and then
8074 Nam
/= TSS_Stream_Read
and then
8075 Nam
/= TSS_Stream_Write
8077 raise Program_Error
;
8080 -- Restriction No_Stream_Optimizations is not set, so we can go
8081 -- ahead and optimize using the block IO forms of the routines.
8084 if Nam
= TSS_Stream_Input
8085 and then Is_Available
(RE_Storage_Array_Input_Blk_IO
)
8087 return RTE
(RE_Storage_Array_Input_Blk_IO
);
8089 elsif Nam
= TSS_Stream_Output
8090 and then Is_Available
(RE_Storage_Array_Output_Blk_IO
)
8092 return RTE
(RE_Storage_Array_Output_Blk_IO
);
8094 elsif Nam
= TSS_Stream_Read
8095 and then Is_Available
(RE_Storage_Array_Read_Blk_IO
)
8097 return RTE
(RE_Storage_Array_Read_Blk_IO
);
8099 elsif Nam
= TSS_Stream_Write
8100 and then Is_Available
(RE_Storage_Array_Write_Blk_IO
)
8102 return RTE
(RE_Storage_Array_Write_Blk_IO
);
8104 elsif Nam
/= TSS_Stream_Input
and then
8105 Nam
/= TSS_Stream_Output
and then
8106 Nam
/= TSS_Stream_Read
and then
8107 Nam
/= TSS_Stream_Write
8109 raise Program_Error
;
8113 -- Stream_Element_Array as defined in package Ada.Streams
8115 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
8117 -- Case of No_Stream_Optimizations restriction active
8119 if Restriction_Active
(No_Stream_Optimizations
) then
8120 if Nam
= TSS_Stream_Input
8121 and then Is_Available
(RE_Stream_Element_Array_Input
)
8123 return RTE
(RE_Stream_Element_Array_Input
);
8125 elsif Nam
= TSS_Stream_Output
8126 and then Is_Available
(RE_Stream_Element_Array_Output
)
8128 return RTE
(RE_Stream_Element_Array_Output
);
8130 elsif Nam
= TSS_Stream_Read
8131 and then Is_Available
(RE_Stream_Element_Array_Read
)
8133 return RTE
(RE_Stream_Element_Array_Read
);
8135 elsif Nam
= TSS_Stream_Write
8136 and then Is_Available
(RE_Stream_Element_Array_Write
)
8138 return RTE
(RE_Stream_Element_Array_Write
);
8140 elsif Nam
/= TSS_Stream_Input
and then
8141 Nam
/= TSS_Stream_Output
and then
8142 Nam
/= TSS_Stream_Read
and then
8143 Nam
/= TSS_Stream_Write
8145 raise Program_Error
;
8148 -- Restriction No_Stream_Optimizations is not set, so we can go
8149 -- ahead and optimize using the block IO forms of the routines.
8152 if Nam
= TSS_Stream_Input
8153 and then Is_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
8155 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
8157 elsif Nam
= TSS_Stream_Output
8158 and then Is_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
8160 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
8162 elsif Nam
= TSS_Stream_Read
8163 and then Is_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
8165 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
8167 elsif Nam
= TSS_Stream_Write
8168 and then Is_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
8170 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
8172 elsif Nam
/= TSS_Stream_Input
and then
8173 Nam
/= TSS_Stream_Output
and then
8174 Nam
/= TSS_Stream_Read
and then
8175 Nam
/= TSS_Stream_Write
8177 raise Program_Error
;
8181 -- String as defined in package Ada
8183 elsif Base_Typ
= Standard_String
then
8185 -- Case of No_Stream_Optimizations restriction active
8187 if Restriction_Active
(No_Stream_Optimizations
) then
8188 if Nam
= TSS_Stream_Input
8189 and then Is_Available
(RE_String_Input
)
8191 return RTE
(RE_String_Input
);
8193 elsif Nam
= TSS_Stream_Output
8194 and then Is_Available
(RE_String_Output
)
8196 return RTE
(RE_String_Output
);
8198 elsif Nam
= TSS_Stream_Read
8199 and then Is_Available
(RE_String_Read
)
8201 return RTE
(RE_String_Read
);
8203 elsif Nam
= TSS_Stream_Write
8204 and then Is_Available
(RE_String_Write
)
8206 return RTE
(RE_String_Write
);
8208 elsif Nam
/= TSS_Stream_Input
and then
8209 Nam
/= TSS_Stream_Output
and then
8210 Nam
/= TSS_Stream_Read
and then
8211 Nam
/= TSS_Stream_Write
8213 raise Program_Error
;
8216 -- Restriction No_Stream_Optimizations is not set, so we can go
8217 -- ahead and optimize using the block IO forms of the routines.
8220 if Nam
= TSS_Stream_Input
8221 and then Is_Available
(RE_String_Input_Blk_IO
)
8223 return RTE
(RE_String_Input_Blk_IO
);
8225 elsif Nam
= TSS_Stream_Output
8226 and then Is_Available
(RE_String_Output_Blk_IO
)
8228 return RTE
(RE_String_Output_Blk_IO
);
8230 elsif Nam
= TSS_Stream_Read
8231 and then Is_Available
(RE_String_Read_Blk_IO
)
8233 return RTE
(RE_String_Read_Blk_IO
);
8235 elsif Nam
= TSS_Stream_Write
8236 and then Is_Available
(RE_String_Write_Blk_IO
)
8238 return RTE
(RE_String_Write_Blk_IO
);
8240 elsif Nam
/= TSS_Stream_Input
and then
8241 Nam
/= TSS_Stream_Output
and then
8242 Nam
/= TSS_Stream_Read
and then
8243 Nam
/= TSS_Stream_Write
8245 raise Program_Error
;
8249 -- Wide_String as defined in package Ada
8251 elsif Base_Typ
= Standard_Wide_String
then
8253 -- Case of No_Stream_Optimizations restriction active
8255 if Restriction_Active
(No_Stream_Optimizations
) then
8256 if Nam
= TSS_Stream_Input
8257 and then Is_Available
(RE_Wide_String_Input
)
8259 return RTE
(RE_Wide_String_Input
);
8261 elsif Nam
= TSS_Stream_Output
8262 and then Is_Available
(RE_Wide_String_Output
)
8264 return RTE
(RE_Wide_String_Output
);
8266 elsif Nam
= TSS_Stream_Read
8267 and then Is_Available
(RE_Wide_String_Read
)
8269 return RTE
(RE_Wide_String_Read
);
8271 elsif Nam
= TSS_Stream_Write
8272 and then Is_Available
(RE_Wide_String_Write
)
8274 return RTE
(RE_Wide_String_Write
);
8276 elsif Nam
/= TSS_Stream_Input
and then
8277 Nam
/= TSS_Stream_Output
and then
8278 Nam
/= TSS_Stream_Read
and then
8279 Nam
/= TSS_Stream_Write
8281 raise Program_Error
;
8284 -- Restriction No_Stream_Optimizations is not set, so we can go
8285 -- ahead and optimize using the block IO forms of the routines.
8288 if Nam
= TSS_Stream_Input
8289 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
8291 return RTE
(RE_Wide_String_Input_Blk_IO
);
8293 elsif Nam
= TSS_Stream_Output
8294 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
8296 return RTE
(RE_Wide_String_Output_Blk_IO
);
8298 elsif Nam
= TSS_Stream_Read
8299 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
8301 return RTE
(RE_Wide_String_Read_Blk_IO
);
8303 elsif Nam
= TSS_Stream_Write
8304 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
8306 return RTE
(RE_Wide_String_Write_Blk_IO
);
8308 elsif Nam
/= TSS_Stream_Input
and then
8309 Nam
/= TSS_Stream_Output
and then
8310 Nam
/= TSS_Stream_Read
and then
8311 Nam
/= TSS_Stream_Write
8313 raise Program_Error
;
8317 -- Wide_Wide_String as defined in package Ada
8319 elsif Base_Typ
= Standard_Wide_Wide_String
then
8321 -- Case of No_Stream_Optimizations restriction active
8323 if Restriction_Active
(No_Stream_Optimizations
) then
8324 if Nam
= TSS_Stream_Input
8325 and then Is_Available
(RE_Wide_Wide_String_Input
)
8327 return RTE
(RE_Wide_Wide_String_Input
);
8329 elsif Nam
= TSS_Stream_Output
8330 and then Is_Available
(RE_Wide_Wide_String_Output
)
8332 return RTE
(RE_Wide_Wide_String_Output
);
8334 elsif Nam
= TSS_Stream_Read
8335 and then Is_Available
(RE_Wide_Wide_String_Read
)
8337 return RTE
(RE_Wide_Wide_String_Read
);
8339 elsif Nam
= TSS_Stream_Write
8340 and then Is_Available
(RE_Wide_Wide_String_Write
)
8342 return RTE
(RE_Wide_Wide_String_Write
);
8344 elsif Nam
/= TSS_Stream_Input
and then
8345 Nam
/= TSS_Stream_Output
and then
8346 Nam
/= TSS_Stream_Read
and then
8347 Nam
/= TSS_Stream_Write
8349 raise Program_Error
;
8352 -- Restriction No_Stream_Optimizations is not set, so we can go
8353 -- ahead and optimize using the block IO forms of the routines.
8356 if Nam
= TSS_Stream_Input
8357 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8359 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8361 elsif Nam
= TSS_Stream_Output
8362 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8364 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8366 elsif Nam
= TSS_Stream_Read
8367 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8369 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8371 elsif Nam
= TSS_Stream_Write
8372 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8374 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8376 elsif Nam
/= TSS_Stream_Input
and then
8377 Nam
/= TSS_Stream_Output
and then
8378 Nam
/= TSS_Stream_Read
and then
8379 Nam
/= TSS_Stream_Write
8381 raise Program_Error
;
8387 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8388 return Find_Prim_Op
(Typ
, Nam
);
8390 return Find_Inherited_TSS
(Typ
, Nam
);
8392 end Find_Stream_Subprogram
;
8398 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8402 BT
:= Base_Type
(T
);
8404 if Is_Private_Type
(BT
)
8405 and then Present
(Full_View
(BT
))
8407 BT
:= Full_View
(BT
);
8413 -----------------------
8414 -- Get_Index_Subtype --
8415 -----------------------
8417 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
8418 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
8423 if Is_Access_Type
(P_Type
) then
8424 P_Type
:= Designated_Type
(P_Type
);
8427 if No
(Expressions
(N
)) then
8430 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
8433 Indx
:= First_Index
(P_Type
);
8439 return Etype
(Indx
);
8440 end Get_Index_Subtype
;
8442 -------------------------------
8443 -- Get_Stream_Convert_Pragma --
8444 -------------------------------
8446 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8451 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8452 -- that a stream convert pragma for a tagged type is not inherited from
8453 -- its parent. Probably what is wrong here is that it is basically
8454 -- incorrect to consider a stream convert pragma to be a representation
8455 -- pragma at all ???
8457 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8458 while Present
(N
) loop
8459 if Nkind
(N
) = N_Pragma
8460 and then Pragma_Name
(N
) = Name_Stream_Convert
8462 -- For tagged types this pragma is not inherited, so we
8463 -- must verify that it is defined for the given type and
8467 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8469 if not Is_Tagged_Type
(T
)
8471 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8481 end Get_Stream_Convert_Pragma
;
8483 ---------------------------------
8484 -- Is_Constrained_Packed_Array --
8485 ---------------------------------
8487 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8488 Arr
: Entity_Id
:= Typ
;
8491 if Is_Access_Type
(Arr
) then
8492 Arr
:= Designated_Type
(Arr
);
8495 return Is_Array_Type
(Arr
)
8496 and then Is_Constrained
(Arr
)
8497 and then Present
(Packed_Array_Impl_Type
(Arr
));
8498 end Is_Constrained_Packed_Array
;
8500 ----------------------------------------
8501 -- Is_Inline_Floating_Point_Attribute --
8502 ----------------------------------------
8504 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8505 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8507 function Is_GCC_Target
return Boolean;
8508 -- Return True if we are using a GCC target/back-end
8509 -- ??? Note: the implementation is kludgy/fragile
8515 function Is_GCC_Target
return Boolean is
8517 return not CodePeer_Mode
8518 and then not Modify_Tree_For_C
;
8521 -- Start of processing for Is_Inline_Floating_Point_Attribute
8524 -- Machine and Model can be expanded by the GCC back end only
8526 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8527 return Is_GCC_Target
;
8529 -- Remaining cases handled by all back ends are Rounding and Truncation
8530 -- when appearing as the operand of a conversion to some integer type.
8532 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8533 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8538 -- Here we are in the integer conversion context
8540 -- Very probably we should also recognize the cases of Machine_Rounding
8541 -- and unbiased rounding in this conversion context, but the back end is
8542 -- not yet prepared to handle these cases ???
8544 return Id
= Attribute_Rounding
or else Id
= Attribute_Truncation
;
8545 end Is_Inline_Floating_Point_Attribute
;