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 Expander
; use Expander
;
43 with Freeze
; use Freeze
;
44 with Gnatvsn
; use Gnatvsn
;
45 with Itypes
; use Itypes
;
47 with Namet
; use Namet
;
48 with Nmake
; use Nmake
;
49 with Nlists
; use Nlists
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 with Sinfo
; use Sinfo
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Tbuild
; use Tbuild
;
67 with Ttypes
; use Ttypes
;
68 with Uintp
; use Uintp
;
69 with Uname
; use Uname
;
70 with Validsw
; use Validsw
;
72 package body Exp_Attr
is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Build_Array_VS_Func
80 Formal_Typ
: Entity_Id
;
81 Array_Typ
: Entity_Id
;
82 Comp_Typ
: Entity_Id
) return Entity_Id
;
83 -- Validate the components of an array type by means of a function. Return
84 -- the entity of the validation function. The parameters are as follows:
86 -- * Attr - the 'Valid_Scalars attribute for which the function is
89 -- * Formal_Typ - the type of the generated function's only formal
92 -- * Array_Typ - the array type whose components are to be validated
94 -- * Comp_Typ - the component type of the array
96 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
97 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
99 function Build_Record_VS_Func
101 Formal_Typ
: Entity_Id
;
102 Rec_Typ
: Entity_Id
) return Entity_Id
;
103 -- Validate the components, discriminants, and variants of a record type by
104 -- means of a function. Return the entity of the validation function. The
105 -- parameters are as follows:
107 -- * Attr - the 'Valid_Scalars attribute for which the function is
110 -- * Formal_Typ - the type of the generated function's only formal
113 -- * Rec_Typ - the record type whose internals are to be validated
115 procedure Compile_Stream_Body_In_Scope
120 -- The body for a stream subprogram may be generated outside of the scope
121 -- of the type. If the type is fully private, it may depend on the full
122 -- view of other types (e.g. indexes) that are currently private as well.
123 -- We install the declarations of the package in which the type is declared
124 -- before compiling the body in what is its proper environment. The Check
125 -- parameter indicates if checks are to be suppressed for the stream body.
126 -- We suppress checks for array/record reads, since the rule is that these
127 -- are like assignments, out of range values due to uninitialized storage,
128 -- or other invalid values do NOT cause a Constraint_Error to be raised.
129 -- If we are within an instance body all visibility has been established
130 -- already and there is no need to install the package.
132 -- This mechanism is now extended to the component types of the array type,
133 -- when the component type is not in scope and is private, to handle
134 -- properly the case when the full view has defaulted discriminants.
136 -- This special processing is ultimately caused by the fact that the
137 -- compiler lacks a well-defined phase when full views are visible
138 -- everywhere. Having such a separate pass would remove much of the
139 -- special-case code that shuffles partial and full views in the middle
140 -- of semantic analysis and expansion.
142 procedure Expand_Access_To_Protected_Op
146 -- An attribute reference to a protected subprogram is transformed into
147 -- a pair of pointers: one to the object, and one to the operations.
148 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
150 procedure Expand_Fpt_Attribute
155 -- This procedure expands a call to a floating-point attribute function.
156 -- N is the attribute reference node, and Args is a list of arguments to
157 -- be passed to the function call. Pkg identifies the package containing
158 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
159 -- have already been converted to the floating-point type for which Pkg was
160 -- instantiated. The Nam argument is the relevant attribute processing
161 -- routine to be called. This is the same as the attribute name, except in
162 -- the Unaligned_Valid case.
164 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
165 -- This procedure expands a call to a floating-point attribute function
166 -- that takes a single floating-point argument. The function to be called
167 -- is always the same as the attribute name.
169 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
170 -- This procedure expands a call to a floating-point attribute function
171 -- that takes one floating-point argument and one integer argument. The
172 -- function to be called is always the same as the attribute name.
174 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
175 -- This procedure expands a call to a floating-point attribute function
176 -- that takes two floating-point arguments. The function to be called
177 -- is always the same as the attribute name.
179 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
180 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
181 -- loop may be converted into a conditional block. See body for details.
183 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
184 -- Handle the expansion of attributes 'Max and 'Min, including expanding
185 -- then out if we are in Modify_Tree_For_C mode.
187 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
188 -- Handles expansion of Pred or Succ attributes for case of non-real
189 -- operand with overflow checking required.
191 procedure Expand_Update_Attribute
(N
: Node_Id
);
192 -- Handle the expansion of attribute Update
194 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
195 -- Used for Last, Last, and Length, when the prefix is an array type.
196 -- Obtains the corresponding index subtype.
198 procedure Find_Fat_Info
200 Fat_Type
: out Entity_Id
;
201 Fat_Pkg
: out RE_Id
);
202 -- Given a floating-point type T, identifies the package containing the
203 -- attributes for this type (returned in Fat_Pkg), and the corresponding
204 -- type for which this package was instantiated from Fat_Gen. Error if T
205 -- is not a floating-point type.
207 function Find_Stream_Subprogram
209 Nam
: TSS_Name_Type
) return Entity_Id
;
210 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
211 -- types, the corresponding primitive operation is looked up, else the
212 -- appropriate TSS from the type itself, or from its closest ancestor
213 -- defining it, is returned. In both cases, inheritance of representation
214 -- aspects is thus taken into account.
216 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
217 -- The stream functions need to examine the underlying representation of
218 -- composite types. In some cases T may be non-private but its base type
219 -- is, in which case the function returns the corresponding full view.
221 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
222 -- Given a type, find a corresponding stream convert pragma that applies to
223 -- the implementation base type of this type (Typ). If found, return the
224 -- pragma node, otherwise return Empty if no pragma is found.
226 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
227 -- Utility for array attributes, returns true on packed constrained
228 -- arrays, and on access to same.
230 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
231 -- Returns true iff the given node refers to an attribute call that
232 -- can be expanded directly by the back end and does not need front end
233 -- expansion. Typically used for rounding and truncation attributes that
234 -- appear directly inside a conversion to integer.
236 -------------------------
237 -- Build_Array_VS_Func --
238 -------------------------
240 function Build_Array_VS_Func
242 Formal_Typ
: Entity_Id
;
243 Array_Typ
: Entity_Id
;
244 Comp_Typ
: Entity_Id
) return Entity_Id
246 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
248 function Validate_Component
250 Indexes
: List_Id
) return Node_Id
;
251 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
252 -- the entity of the validation parameter. Return the check associated
253 -- with the component.
255 function Validate_Dimension
258 Indexes
: List_Id
) return Node_Id
;
259 -- Process dimension Dim of the array type. Obj_Id denotes the entity
260 -- of the validation parameter. Indexes is a list where each dimension
261 -- deposits its loop variable, which will later identify a component.
262 -- Return the loop associated with the current dimension.
264 ------------------------
265 -- Validate_Component --
266 ------------------------
268 function Validate_Component
270 Indexes
: List_Id
) return Node_Id
275 if Is_Scalar_Type
(Comp_Typ
) then
276 Attr_Nam
:= Name_Valid
;
278 Attr_Nam
:= Name_Valid_Scalars
;
282 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
287 Make_If_Statement
(Loc
,
291 Make_Attribute_Reference
(Loc
,
293 Make_Indexed_Component
(Loc
,
295 Unchecked_Convert_To
(Array_Typ
,
296 New_Occurrence_Of
(Obj_Id
, Loc
)),
297 Expressions
=> Indexes
),
298 Attribute_Name
=> Attr_Nam
)),
300 Then_Statements
=> New_List
(
301 Make_Simple_Return_Statement
(Loc
,
302 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
303 end Validate_Component
;
305 ------------------------
306 -- Validate_Dimension --
307 ------------------------
309 function Validate_Dimension
312 Indexes
: List_Id
) return Node_Id
317 -- Validate the component once all dimensions have produced their
320 if Dim
> Number_Dimensions
(Array_Typ
) then
321 return Validate_Component
(Obj_Id
, Indexes
);
323 -- Process the current dimension
327 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
));
329 Append_To
(Indexes
, New_Occurrence_Of
(Index
, Loc
));
332 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
333 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
334 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
342 Make_Implicit_Loop_Statement
(Attr
,
345 Make_Iteration_Scheme
(Loc
,
346 Loop_Parameter_Specification
=>
347 Make_Loop_Parameter_Specification
(Loc
,
348 Defining_Identifier
=> Index
,
349 Discrete_Subtype_Definition
=>
350 Make_Attribute_Reference
(Loc
,
352 Unchecked_Convert_To
(Array_Typ
,
353 New_Occurrence_Of
(Obj_Id
, Loc
)),
354 Attribute_Name
=> Name_Range
,
355 Expressions
=> New_List
(
356 Make_Integer_Literal
(Loc
, Dim
))))),
357 Statements
=> New_List
(
358 Validate_Dimension
(Obj_Id
, Dim
+ 1, Indexes
)));
360 end Validate_Dimension
;
364 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
365 Indexes
: constant List_Id
:= New_List
;
366 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
369 -- Start of processing for Build_Array_VS_Func
372 Stmts
:= New_List
(Validate_Dimension
(Obj_Id
, 1, Indexes
));
378 Make_Simple_Return_Statement
(Loc
,
379 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
382 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
387 Set_Ekind
(Func_Id
, E_Function
);
388 Set_Is_Internal
(Func_Id
);
389 Set_Is_Pure
(Func_Id
);
391 if not Debug_Generated_Code
then
392 Set_Debug_Info_Off
(Func_Id
);
396 Make_Subprogram_Body
(Loc
,
398 Make_Function_Specification
(Loc
,
399 Defining_Unit_Name
=> Func_Id
,
400 Parameter_Specifications
=> New_List
(
401 Make_Parameter_Specification
(Loc
,
402 Defining_Identifier
=> Obj_Id
,
404 Out_Present
=> False,
405 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
407 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
408 Declarations
=> New_List
,
409 Handled_Statement_Sequence
=>
410 Make_Handled_Sequence_Of_Statements
(Loc
,
411 Statements
=> Stmts
)));
414 end Build_Array_VS_Func
;
416 ---------------------------------
417 -- Build_Disp_Get_Task_Id_Call --
418 ---------------------------------
420 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
421 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
422 Typ
: constant Entity_Id
:= Etype
(Actual
);
423 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
427 -- _Disp_Get_Task_Id (Actual)
430 Make_Function_Call
(Loc
,
431 Name
=> New_Occurrence_Of
(Subp
, Loc
),
432 Parameter_Associations
=> New_List
(Actual
));
433 end Build_Disp_Get_Task_Id_Call
;
435 --------------------------
436 -- Build_Record_VS_Func --
437 --------------------------
439 function Build_Record_VS_Func
441 Formal_Typ
: Entity_Id
;
442 Rec_Typ
: Entity_Id
) return Entity_Id
444 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
445 -- It generates code only when there are components, discriminants,
446 -- or variant parts to validate.
448 -- NOTE: The routines within Build_Record_VS_Func are intentionally
449 -- unnested to avoid deep indentation of code.
451 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
453 procedure Validate_Component_List
456 Stmts
: in out List_Id
);
457 -- Process all components and variant parts of component list Comp_List.
458 -- Obj_Id denotes the entity of the validation parameter. All new code
459 -- is added to list Stmts.
461 procedure Validate_Field
464 Cond
: in out Node_Id
);
465 -- Process component declaration or discriminant specification Field.
466 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
467 -- an "or else" conditional expression which contains the new code (if
470 procedure Validate_Fields
473 Stmts
: in out List_Id
);
474 -- Process component declarations or discriminant specifications in list
475 -- Fields. Obj_Id denotes the entity of the validation parameter. All
476 -- new code is added to list Stmts.
478 procedure Validate_Variant
481 Alts
: in out List_Id
);
482 -- Process variant Var. Obj_Id denotes the entity of the validation
483 -- parameter. Alts denotes a list of case statement alternatives which
484 -- contains the new code (if any).
486 procedure Validate_Variant_Part
489 Stmts
: in out List_Id
);
490 -- Process variant part Var_Part. Obj_Id denotes the entity of the
491 -- validation parameter. All new code is added to list Stmts.
493 -----------------------------
494 -- Validate_Component_List --
495 -----------------------------
497 procedure Validate_Component_List
500 Stmts
: in out List_Id
)
502 Var_Part
: constant Node_Id
:= Variant_Part
(Comp_List
);
505 -- Validate all components
509 Fields
=> Component_Items
(Comp_List
),
512 -- Validate the variant part
514 if Present
(Var_Part
) then
515 Validate_Variant_Part
517 Var_Part
=> Var_Part
,
520 end Validate_Component_List
;
526 procedure Validate_Field
529 Cond
: in out Node_Id
)
531 Field_Id
: constant Entity_Id
:= Defining_Entity
(Field
);
532 Field_Nam
: constant Name_Id
:= Chars
(Field_Id
);
533 Field_Typ
: constant Entity_Id
:= Validated_View
(Etype
(Field_Id
));
537 -- Do not process internally-generated fields. Note that checking for
538 -- Comes_From_Source is not correct because this will eliminate the
539 -- components within the corresponding record of a protected type.
541 if Nam_In
(Field_Nam
, Name_uObject
,
547 -- Do not process fields without any scalar components
549 elsif not Scalar_Part_Present
(Field_Typ
) then
552 -- Otherwise the field needs to be validated. Use Make_Identifier
553 -- rather than New_Occurrence_Of to identify the field because the
554 -- wrong entity may be picked up when private types are involved.
557 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
560 if Is_Scalar_Type
(Field_Typ
) then
561 Attr_Nam
:= Name_Valid
;
563 Attr_Nam
:= Name_Valid_Scalars
;
566 Evolve_Or_Else
(Cond
,
569 Make_Attribute_Reference
(Loc
,
571 Make_Selected_Component
(Loc
,
573 Unchecked_Convert_To
(Rec_Typ
,
574 New_Occurrence_Of
(Obj_Id
, Loc
)),
575 Selector_Name
=> Make_Identifier
(Loc
, Field_Nam
)),
576 Attribute_Name
=> Attr_Nam
)));
580 ---------------------
581 -- Validate_Fields --
582 ---------------------
584 procedure Validate_Fields
587 Stmts
: in out List_Id
)
593 -- Assume that none of the fields are eligible for verification
597 -- Validate all fields
599 Field
:= First_Non_Pragma
(Fields
);
600 while Present
(Field
) loop
606 Next_Non_Pragma
(Field
);
610 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
611 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
616 if Present
(Cond
) then
617 Append_New_To
(Stmts
,
618 Make_Implicit_If_Statement
(Attr
,
620 Then_Statements
=> New_List
(
621 Make_Simple_Return_Statement
(Loc
,
622 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
626 ----------------------
627 -- Validate_Variant --
628 ----------------------
630 procedure Validate_Variant
633 Alts
: in out List_Id
)
638 -- Assume that none of the components and variants are eligible for
643 -- Validate components
645 Validate_Component_List
647 Comp_List
=> Component_List
(Var
),
650 -- Generate a null statement in case none of the components were
651 -- verified because this will otherwise eliminate an alternative
652 -- from the variant case statement and render the generated code
656 Append_New_To
(Stmts
, Make_Null_Statement
(Loc
));
660 -- when Discrete_Choices =>
664 Make_Case_Statement_Alternative
(Loc
,
666 New_Copy_List_Tree
(Discrete_Choices
(Var
)),
667 Statements
=> Stmts
));
668 end Validate_Variant
;
670 ---------------------------
671 -- Validate_Variant_Part --
672 ---------------------------
674 procedure Validate_Variant_Part
677 Stmts
: in out List_Id
)
679 Vars
: constant List_Id
:= Variants
(Var_Part
);
684 -- Assume that none of the variants are eligible for verification
690 Var
:= First_Non_Pragma
(Vars
);
691 while Present
(Var
) loop
697 Next_Non_Pragma
(Var
);
700 -- Even though individual variants may lack eligible components, the
701 -- alternatives must still be generated.
703 pragma Assert
(Present
(Alts
));
706 -- case Rec_Typ (Obj_Id).Discriminant is
707 -- when Discrete_Choices_1 =>
709 -- when Discrete_Choices_N =>
713 Append_New_To
(Stmts
,
714 Make_Case_Statement
(Loc
,
716 Make_Selected_Component
(Loc
,
718 Unchecked_Convert_To
(Rec_Typ
,
719 New_Occurrence_Of
(Obj_Id
, Loc
)),
720 Selector_Name
=> New_Copy_Tree
(Name
(Var_Part
))),
721 Alternatives
=> Alts
));
722 end Validate_Variant_Part
;
726 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
727 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
735 -- Start of processing for Build_Record_VS_Func
740 -- Use the root type when dealing with a class-wide type
742 if Is_Class_Wide_Type
(Typ
) then
743 Typ
:= Root_Type
(Typ
);
746 Typ_Decl
:= Declaration_Node
(Typ
);
747 Typ_Def
:= Type_Definition
(Typ_Decl
);
749 -- The components of a derived type are located in the extension part
751 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
752 Typ_Ext
:= Record_Extension_Part
(Typ_Def
);
754 if Present
(Typ_Ext
) then
755 Comps
:= Component_List
(Typ_Ext
);
760 -- Otherwise the components are available in the definition
763 Comps
:= Component_List
(Typ_Def
);
766 -- The code generated by this routine is as follows:
768 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
770 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
771 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
776 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
777 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
782 -- case Discriminant_1 is
784 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
785 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
790 -- case Discriminant_N is
799 -- Assume that the record type lacks eligible components, discriminants,
800 -- and variant parts.
804 -- Validate the discriminants
806 if not Is_Unchecked_Union
(Rec_Typ
) then
809 Fields
=> Discriminant_Specifications
(Typ_Decl
),
813 -- Validate the components and variant parts
815 Validate_Component_List
823 Append_New_To
(Stmts
,
824 Make_Simple_Return_Statement
(Loc
,
825 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
828 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
833 Set_Ekind
(Func_Id
, E_Function
);
834 Set_Is_Internal
(Func_Id
);
835 Set_Is_Pure
(Func_Id
);
837 if not Debug_Generated_Code
then
838 Set_Debug_Info_Off
(Func_Id
);
842 Make_Subprogram_Body
(Loc
,
844 Make_Function_Specification
(Loc
,
845 Defining_Unit_Name
=> Func_Id
,
846 Parameter_Specifications
=> New_List
(
847 Make_Parameter_Specification
(Loc
,
848 Defining_Identifier
=> Obj_Id
,
849 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
851 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
852 Declarations
=> New_List
,
853 Handled_Statement_Sequence
=>
854 Make_Handled_Sequence_Of_Statements
(Loc
,
855 Statements
=> Stmts
)),
856 Suppress
=> Discriminant_Check
);
859 end Build_Record_VS_Func
;
861 ----------------------------------
862 -- Compile_Stream_Body_In_Scope --
863 ----------------------------------
865 procedure Compile_Stream_Body_In_Scope
871 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
872 Curr
: constant Entity_Id
:= Current_Scope
;
873 Install
: Boolean := False;
874 Scop
: Entity_Id
:= Scope
(Arr
);
878 and then not In_Open_Scopes
(Scop
)
879 and then Ekind
(Scop
) = E_Package
884 -- The component type may be private, in which case we install its
885 -- full view to compile the subprogram.
887 -- The component type may be private, in which case we install its
888 -- full view to compile the subprogram. We do not do this if the
889 -- type has a Stream_Convert pragma, which indicates that there are
890 -- special stream-processing operations for that type (for example
891 -- Unbounded_String and its wide varieties).
893 Scop
:= Scope
(C_Type
);
895 if Is_Private_Type
(C_Type
)
896 and then Present
(Full_View
(C_Type
))
897 and then not In_Open_Scopes
(Scop
)
898 and then Ekind
(Scop
) = E_Package
899 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
905 -- If we are within an instance body, then all visibility has been
906 -- established already and there is no need to install the package.
908 if Install
and then not In_Instance_Body
then
910 Install_Visible_Declarations
(Scop
);
911 Install_Private_Declarations
(Scop
);
913 -- The entities in the package are now visible, but the generated
914 -- stream entity must appear in the current scope (usually an
915 -- enclosing stream function) so that itypes all have their proper
924 Insert_Action
(N
, Decl
);
926 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
931 -- Remove extra copy of current scope, and package itself
934 End_Package_Scope
(Scop
);
936 end Compile_Stream_Body_In_Scope
;
938 -----------------------------------
939 -- Expand_Access_To_Protected_Op --
940 -----------------------------------
942 procedure Expand_Access_To_Protected_Op
947 -- The value of the attribute_reference is a record containing two
948 -- fields: an access to the protected object, and an access to the
949 -- subprogram itself. The prefix is a selected component.
951 Loc
: constant Source_Ptr
:= Sloc
(N
);
953 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
956 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
957 Acc
: constant Entity_Id
:=
958 Etype
(Next_Component
(First_Component
(E_T
)));
962 -- Start of processing for Expand_Access_To_Protected_Op
965 -- Within the body of the protected type, the prefix designates a local
966 -- operation, and the object is the first parameter of the corresponding
967 -- protected body of the current enclosing operation.
969 if Is_Entity_Name
(Pref
) then
970 -- All indirect calls are external calls, so must do locking and
971 -- barrier reevaluation, even if the 'Access occurs within the
972 -- protected body. Hence the call to External_Subprogram, as opposed
973 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
974 -- that indirect calls from within the same protected body will
975 -- deadlock, as allowed by RM-9.5.1(8,15,17).
977 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
979 -- Don't traverse the scopes when the attribute occurs within an init
980 -- proc, because we directly use the _init formal of the init proc in
983 Curr
:= Current_Scope
;
984 if not Is_Init_Proc
(Curr
) then
985 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
987 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
988 Curr
:= Scope
(Curr
);
992 -- In case of protected entries the first formal of its Protected_
993 -- Body_Subprogram is the address of the object.
995 if Ekind
(Curr
) = E_Entry
then
999 (Protected_Body_Subprogram
(Curr
)), Loc
);
1001 -- If the current scope is an init proc, then use the address of the
1002 -- _init formal as the object reference.
1004 elsif Is_Init_Proc
(Curr
) then
1006 Make_Attribute_Reference
(Loc
,
1007 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
1008 Attribute_Name
=> Name_Address
);
1010 -- In case of protected subprograms the first formal of its
1011 -- Protected_Body_Subprogram is the object and we get its address.
1015 Make_Attribute_Reference
(Loc
,
1019 (Protected_Body_Subprogram
(Curr
)), Loc
),
1020 Attribute_Name
=> Name_Address
);
1023 -- Case where the prefix is not an entity name. Find the
1024 -- version of the protected operation to be called from
1025 -- outside the protected object.
1030 (External_Subprogram
1031 (Entity
(Selector_Name
(Pref
))), Loc
);
1034 Make_Attribute_Reference
(Loc
,
1035 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1036 Attribute_Name
=> Name_Address
);
1040 Make_Attribute_Reference
(Loc
,
1042 Attribute_Name
=> Name_Access
);
1044 -- We set the type of the access reference to the already generated
1045 -- access_to_subprogram type, and declare the reference analyzed, to
1046 -- prevent further expansion when the enclosing aggregate is analyzed.
1048 Set_Etype
(Sub_Ref
, Acc
);
1049 Set_Analyzed
(Sub_Ref
);
1052 Make_Aggregate
(Loc
,
1053 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1055 -- Sub_Ref has been marked as analyzed, but we still need to make sure
1056 -- Sub is correctly frozen.
1058 Freeze_Before
(N
, Entity
(Sub
));
1061 Analyze_And_Resolve
(N
, E_T
);
1063 -- For subsequent analysis, the node must retain its type. The backend
1064 -- will replace it with the equivalent type where needed.
1067 end Expand_Access_To_Protected_Op
;
1069 --------------------------
1070 -- Expand_Fpt_Attribute --
1071 --------------------------
1073 procedure Expand_Fpt_Attribute
1079 Loc
: constant Source_Ptr
:= Sloc
(N
);
1080 Typ
: constant Entity_Id
:= Etype
(N
);
1084 -- The function name is the selected component Attr_xxx.yyy where
1085 -- Attr_xxx is the package name, and yyy is the argument Nam.
1087 -- Note: it would be more usual to have separate RE entries for each
1088 -- of the entities in the Fat packages, but first they have identical
1089 -- names (so we would have to have lots of renaming declarations to
1090 -- meet the normal RE rule of separate names for all runtime entities),
1091 -- and second there would be an awful lot of them.
1094 Make_Selected_Component
(Loc
,
1095 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
1096 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
1098 -- The generated call is given the provided set of parameters, and then
1099 -- wrapped in a conversion which converts the result to the target type
1100 -- We use the base type as the target because a range check may be
1104 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
1105 Make_Function_Call
(Loc
,
1107 Parameter_Associations
=> Args
)));
1109 Analyze_And_Resolve
(N
, Typ
);
1110 end Expand_Fpt_Attribute
;
1112 ----------------------------
1113 -- Expand_Fpt_Attribute_R --
1114 ----------------------------
1116 -- The single argument is converted to its root type to call the
1117 -- appropriate runtime function, with the actual call being built
1118 -- by Expand_Fpt_Attribute
1120 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
1121 E1
: constant Node_Id
:= First
(Expressions
(N
));
1125 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1126 Expand_Fpt_Attribute
1127 (N
, Pkg
, Attribute_Name
(N
),
1128 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
1129 end Expand_Fpt_Attribute_R
;
1131 -----------------------------
1132 -- Expand_Fpt_Attribute_RI --
1133 -----------------------------
1135 -- The first argument is converted to its root type and the second
1136 -- argument is converted to standard long long integer to call the
1137 -- appropriate runtime function, with the actual call being built
1138 -- by Expand_Fpt_Attribute
1140 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
1141 E1
: constant Node_Id
:= First
(Expressions
(N
));
1144 E2
: constant Node_Id
:= Next
(E1
);
1146 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1147 Expand_Fpt_Attribute
1148 (N
, Pkg
, Attribute_Name
(N
),
1150 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1151 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
1152 end Expand_Fpt_Attribute_RI
;
1154 -----------------------------
1155 -- Expand_Fpt_Attribute_RR --
1156 -----------------------------
1158 -- The two arguments are converted to their root types to call the
1159 -- appropriate runtime function, with the actual call being built
1160 -- by Expand_Fpt_Attribute
1162 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
1163 E1
: constant Node_Id
:= First
(Expressions
(N
));
1164 E2
: constant Node_Id
:= Next
(E1
);
1169 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1170 Expand_Fpt_Attribute
1171 (N
, Pkg
, Attribute_Name
(N
),
1173 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1174 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
1175 end Expand_Fpt_Attribute_RR
;
1177 ---------------------------------
1178 -- Expand_Loop_Entry_Attribute --
1179 ---------------------------------
1181 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
1182 procedure Build_Conditional_Block
1185 Loop_Stmt
: Node_Id
;
1186 If_Stmt
: out Node_Id
;
1187 Blk_Stmt
: out Node_Id
);
1188 -- Create a block Blk_Stmt with an empty declarative list and a single
1189 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1190 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1192 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
1193 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1196 -----------------------------
1197 -- Build_Conditional_Block --
1198 -----------------------------
1200 procedure Build_Conditional_Block
1203 Loop_Stmt
: Node_Id
;
1204 If_Stmt
: out Node_Id
;
1205 Blk_Stmt
: out Node_Id
)
1208 -- Do not reanalyze the original loop statement because it is simply
1211 Set_Analyzed
(Loop_Stmt
);
1214 Make_Block_Statement
(Loc
,
1215 Declarations
=> New_List
,
1216 Handled_Statement_Sequence
=>
1217 Make_Handled_Sequence_Of_Statements
(Loc
,
1218 Statements
=> New_List
(Loop_Stmt
)));
1220 if Present
(Cond
) then
1222 Make_If_Statement
(Loc
,
1224 Then_Statements
=> New_List
(Blk_Stmt
));
1228 end Build_Conditional_Block
;
1230 ------------------------
1231 -- Is_Array_Iteration --
1232 ------------------------
1234 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1235 Stmt
: constant Node_Id
:= Original_Node
(N
);
1239 if Nkind
(Stmt
) = N_Loop_Statement
1240 and then Present
(Iteration_Scheme
(Stmt
))
1241 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1243 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1246 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1250 end Is_Array_Iteration
;
1254 Pref
: constant Node_Id
:= Prefix
(N
);
1255 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1256 Exprs
: constant List_Id
:= Expressions
(N
);
1258 Blk
: Node_Id
:= Empty
;
1260 Installed
: Boolean;
1262 Loop_Id
: Entity_Id
;
1263 Loop_Stmt
: Node_Id
;
1264 Result
: Node_Id
:= Empty
;
1266 Temp_Decl
: Node_Id
;
1267 Temp_Id
: Entity_Id
;
1269 -- Start of processing for Expand_Loop_Entry_Attribute
1272 -- Step 1: Find the related loop
1274 -- The loop label variant of attribute 'Loop_Entry already has all the
1275 -- information in its expression.
1277 if Present
(Exprs
) then
1278 Loop_Id
:= Entity
(First
(Exprs
));
1279 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1281 -- Climb the parent chain to find the nearest enclosing loop. Skip
1282 -- all internally generated loops for quantified expressions and for
1283 -- element iterators over multidimensional arrays because the pragma
1284 -- applies to source loop.
1288 while Present
(Loop_Stmt
) loop
1289 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1290 and then Nkind
(Original_Node
(Loop_Stmt
)) = N_Loop_Statement
1291 and then Comes_From_Source
(Original_Node
(Loop_Stmt
))
1296 Loop_Stmt
:= Parent
(Loop_Stmt
);
1299 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1302 Loc
:= Sloc
(Loop_Stmt
);
1304 -- Step 2: Transform the loop
1306 -- The loop has already been transformed during the expansion of a prior
1307 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1309 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1311 -- When the related loop name appears as the argument of attribute
1312 -- Loop_Entry, the corresponding label construct is the generated
1313 -- block statement. This is because the expander reuses the label.
1315 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1316 Decls
:= Declarations
(Loop_Stmt
);
1318 -- In all other cases, the loop must appear in the handled sequence
1319 -- of statements of the generated block.
1323 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1325 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1327 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1330 -- Transform the loop into a conditional block
1333 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1334 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1336 -- Infinite loops are transformed into:
1339 -- Temp1 : constant <type of Pref1> := <Pref1>;
1341 -- TempN : constant <type of PrefN> := <PrefN>;
1344 -- <original source statements with attribute rewrites>
1349 Build_Conditional_Block
(Loc
,
1351 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1357 -- While loops are transformed into:
1359 -- function Fnn return Boolean is
1361 -- <condition actions>
1362 -- return <condition>;
1367 -- Temp1 : constant <type of Pref1> := <Pref1>;
1369 -- TempN : constant <type of PrefN> := <PrefN>;
1372 -- <original source statements with attribute rewrites>
1373 -- exit when not Fnn;
1378 -- Note that loops over iterators and containers are already
1379 -- converted into while loops.
1381 elsif Present
(Condition
(Scheme
)) then
1383 Func_Decl
: Node_Id
;
1384 Func_Id
: Entity_Id
;
1388 Func_Id
:= Make_Temporary
(Loc
, 'F');
1390 -- Wrap the condition of the while loop in a Boolean function.
1391 -- This avoids the duplication of the same code which may lead
1392 -- to gigi issues with respect to multiple declaration of the
1393 -- same entity in the presence of side effects or checks. Note
1394 -- that the condition actions must also be relocated into the
1395 -- wrapping function because they may contain itypes, e.g. in
1396 -- the case of a comparison involving slices.
1399 -- <condition actions>
1400 -- return <condition>;
1402 if Present
(Condition_Actions
(Scheme
)) then
1403 Stmts
:= Condition_Actions
(Scheme
);
1409 Make_Simple_Return_Statement
(Loc
,
1411 New_Copy_Tree
(Condition
(Scheme
),
1412 New_Scope
=> Func_Id
)));
1415 -- function Fnn return Boolean is
1421 Make_Subprogram_Body
(Loc
,
1423 Make_Function_Specification
(Loc
,
1424 Defining_Unit_Name
=> Func_Id
,
1425 Result_Definition
=>
1426 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1427 Declarations
=> Empty_List
,
1428 Handled_Statement_Sequence
=>
1429 Make_Handled_Sequence_Of_Statements
(Loc
,
1430 Statements
=> Stmts
));
1432 -- The function is inserted before the related loop. Make sure
1433 -- to analyze it in the context of the loop's enclosing scope.
1435 Push_Scope
(Scope
(Loop_Id
));
1436 Insert_Action
(Loop_Stmt
, Func_Decl
);
1439 -- The analysis of the condition may have generated itypes
1440 -- that are now used within the function: Adjust their
1441 -- scopes accordingly so that their use appears in their
1442 -- scope of definition.
1448 Ityp
:= First_Entity
(Loop_Id
);
1450 while Present
(Ityp
) loop
1451 if Is_Itype
(Ityp
) then
1452 Set_Scope
(Ityp
, Func_Id
);
1458 -- Transform the original while loop into an infinite loop
1459 -- where the last statement checks the negated condition. This
1460 -- placement ensures that the condition will not be evaluated
1461 -- twice on the first iteration.
1463 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1467 -- exit when not Fnn;
1469 Append_To
(Statements
(Loop_Stmt
),
1470 Make_Exit_Statement
(Loc
,
1474 Make_Function_Call
(Loc
,
1475 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1477 Build_Conditional_Block
(Loc
,
1479 Make_Function_Call
(Loc
,
1480 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1481 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1486 -- Ada 2012 iteration over an array is transformed into:
1488 -- if <Array_Nam>'Length (1) > 0
1489 -- and then <Array_Nam>'Length (N) > 0
1492 -- Temp1 : constant <type of Pref1> := <Pref1>;
1494 -- TempN : constant <type of PrefN> := <PrefN>;
1496 -- for X in ... loop -- multiple loops depending on dims
1497 -- <original source statements with attribute rewrites>
1502 elsif Is_Array_Iteration
(Loop_Stmt
) then
1504 Array_Nam
: constant Entity_Id
:=
1505 Entity
(Name
(Iterator_Specification
1506 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1507 Num_Dims
: constant Pos
:=
1508 Number_Dimensions
(Etype
(Array_Nam
));
1509 Cond
: Node_Id
:= Empty
;
1513 -- Generate a check which determines whether all dimensions of
1514 -- the array are non-null.
1516 for Dim
in 1 .. Num_Dims
loop
1520 Make_Attribute_Reference
(Loc
,
1521 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1522 Attribute_Name
=> Name_Length
,
1523 Expressions
=> New_List
(
1524 Make_Integer_Literal
(Loc
, Dim
))),
1526 Make_Integer_Literal
(Loc
, 0));
1534 Right_Opnd
=> Check
);
1538 Build_Conditional_Block
(Loc
,
1540 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1545 -- For loops are transformed into:
1547 -- if <Low> <= <High> then
1549 -- Temp1 : constant <type of Pref1> := <Pref1>;
1551 -- TempN : constant <type of PrefN> := <PrefN>;
1553 -- for <Def_Id> in <Low> .. <High> loop
1554 -- <original source statements with attribute rewrites>
1559 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1561 Loop_Spec
: constant Node_Id
:=
1562 Loop_Parameter_Specification
(Scheme
);
1567 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1569 -- When the loop iterates over a subtype indication with a
1570 -- range, use the low and high bounds of the subtype itself.
1572 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1573 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1576 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1583 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1584 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1586 Build_Conditional_Block
(Loc
,
1588 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1594 Decls
:= Declarations
(Blk
);
1597 -- Step 3: Create a constant to capture the value of the prefix at the
1598 -- entry point into the loop.
1600 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1602 -- Preserve the tag of the prefix by offering a specific view of the
1603 -- class-wide version of the prefix.
1605 if Is_Tagged_Type
(Base_Typ
) then
1606 Tagged_Case
: declare
1607 CW_Temp
: Entity_Id
;
1612 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1614 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1615 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1618 Make_Object_Declaration
(Loc
,
1619 Defining_Identifier
=> CW_Temp
,
1620 Constant_Present
=> True,
1621 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1623 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1624 Append_To
(Decls
, Aux_Decl
);
1627 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1630 Make_Object_Renaming_Declaration
(Loc
,
1631 Defining_Identifier
=> Temp_Id
,
1632 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1634 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1635 Append_To
(Decls
, Temp_Decl
);
1641 Untagged_Case
: declare
1642 Temp_Expr
: Node_Id
;
1647 -- Generate a nominal type for the constant when the prefix is of
1648 -- a constrained type. This is achieved by setting the Etype of
1649 -- the relocated prefix to its base type. Since the prefix is now
1650 -- the initialization expression of the constant, its freezing
1651 -- will produce a proper nominal type.
1653 Temp_Expr
:= Relocate_Node
(Pref
);
1654 Set_Etype
(Temp_Expr
, Base_Typ
);
1657 -- Temp : constant Base_Typ := Pref;
1660 Make_Object_Declaration
(Loc
,
1661 Defining_Identifier
=> Temp_Id
,
1662 Constant_Present
=> True,
1663 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1664 Expression
=> Temp_Expr
);
1665 Append_To
(Decls
, Temp_Decl
);
1669 -- Step 4: Analyze all bits
1671 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1673 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1674 -- associated loop, ensure the proper visibility for analysis.
1676 if not Installed
then
1677 Push_Scope
(Scope
(Loop_Id
));
1680 -- The analysis of the conditional block takes care of the constant
1683 if Present
(Result
) then
1684 Rewrite
(Loop_Stmt
, Result
);
1685 Analyze
(Loop_Stmt
);
1687 -- The conditional block was analyzed when a previous 'Loop_Entry was
1688 -- expanded. There is no point in reanalyzing the block, simply analyze
1689 -- the declaration of the constant.
1692 if Present
(Aux_Decl
) then
1696 Analyze
(Temp_Decl
);
1699 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1702 if not Installed
then
1705 end Expand_Loop_Entry_Attribute
;
1707 ------------------------------
1708 -- Expand_Min_Max_Attribute --
1709 ------------------------------
1711 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1713 -- Min and Max are handled by the back end (except that static cases
1714 -- have already been evaluated during semantic processing, although the
1715 -- back end should not count on this). The one bit of special processing
1716 -- required in the normal case is that these two attributes typically
1717 -- generate conditionals in the code, so check the relevant restriction.
1719 Check_Restriction
(No_Implicit_Conditionals
, N
);
1720 end Expand_Min_Max_Attribute
;
1722 ----------------------------------
1723 -- Expand_N_Attribute_Reference --
1724 ----------------------------------
1726 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1727 Loc
: constant Source_Ptr
:= Sloc
(N
);
1728 Typ
: constant Entity_Id
:= Etype
(N
);
1729 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1730 Pref
: constant Node_Id
:= Prefix
(N
);
1731 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1732 Exprs
: constant List_Id
:= Expressions
(N
);
1733 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1735 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1736 -- Rewrites a stream attribute for Read, Write or Output with the
1737 -- procedure call. Pname is the entity for the procedure to call.
1739 ------------------------------
1740 -- Rewrite_Stream_Proc_Call --
1741 ------------------------------
1743 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1744 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1745 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1746 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1747 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1748 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1751 -- The expansion depends on Item, the second actual, which is
1752 -- the object being streamed in or out.
1754 -- If the item is a component of a packed array type, and
1755 -- a conversion is needed on exit, we introduce a temporary to
1756 -- hold the value, because otherwise the packed reference will
1757 -- not be properly expanded.
1759 if Nkind
(Item
) = N_Indexed_Component
1760 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1761 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1765 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1771 Make_Object_Declaration
(Loc
,
1772 Defining_Identifier
=> Temp
,
1773 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1774 Set_Etype
(Temp
, Formal_Typ
);
1777 Make_Assignment_Statement
(Loc
,
1778 Name
=> New_Copy_Tree
(Item
),
1780 Unchecked_Convert_To
1781 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1783 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1787 Make_Procedure_Call_Statement
(Loc
,
1788 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1789 Parameter_Associations
=> Exprs
),
1792 Rewrite
(N
, Make_Null_Statement
(Loc
));
1797 -- For the class-wide dispatching cases, and for cases in which
1798 -- the base type of the second argument matches the base type of
1799 -- the corresponding formal parameter (that is to say the stream
1800 -- operation is not inherited), we are all set, and can use the
1801 -- argument unchanged.
1803 if not Is_Class_Wide_Type
(Entity
(Pref
))
1804 and then not Is_Class_Wide_Type
(Etype
(Item
))
1805 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1807 -- Perform a view conversion when either the argument or the
1808 -- formal parameter are of a private type.
1810 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1811 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1814 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1816 -- Otherwise perform a regular type conversion to ensure that all
1817 -- relevant checks are installed.
1820 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1823 -- For untagged derived types set Assignment_OK, to prevent
1824 -- copies from being created when the unchecked conversion
1825 -- is expanded (which would happen in Remove_Side_Effects
1826 -- if Expand_N_Unchecked_Conversion were allowed to call
1827 -- Force_Evaluation). The copy could violate Ada semantics in
1828 -- cases such as an actual that is an out parameter. Note that
1829 -- this approach is also used in exp_ch7 for calls to controlled
1830 -- type operations to prevent problems with actuals wrapped in
1831 -- unchecked conversions.
1833 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1834 Set_Assignment_OK
(Item
);
1838 -- The stream operation to call may be a renaming created by an
1839 -- attribute definition clause, and may not be frozen yet. Ensure
1840 -- that it has the necessary extra formals.
1842 if not Is_Frozen
(Pname
) then
1843 Create_Extra_Formals
(Pname
);
1846 -- And now rewrite the call
1849 Make_Procedure_Call_Statement
(Loc
,
1850 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1851 Parameter_Associations
=> Exprs
));
1854 end Rewrite_Stream_Proc_Call
;
1856 -- Start of processing for Expand_N_Attribute_Reference
1859 -- Do required validity checking, if enabled. Do not apply check to
1860 -- output parameters of an Asm instruction, since the value of this
1861 -- is not set till after the attribute has been elaborated, and do
1862 -- not apply the check to the arguments of a 'Read or 'Input attribute
1863 -- reference since the scalar argument is an OUT scalar.
1865 if Validity_Checks_On
and then Validity_Check_Operands
1866 and then Id
/= Attribute_Asm_Output
1867 and then Id
/= Attribute_Read
1868 and then Id
/= Attribute_Input
1873 Expr
:= First
(Expressions
(N
));
1874 while Present
(Expr
) loop
1875 Ensure_Valid
(Expr
);
1881 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1882 -- place function, then a temporary return object needs to be created
1883 -- and access to it must be passed to the function.
1885 if Is_Build_In_Place_Function_Call
(Pref
) then
1887 -- If attribute is 'Old, the context is a postcondition, and
1888 -- the temporary must go in the corresponding subprogram, not
1889 -- the postcondition function or any created blocks, as when
1890 -- the attribute appears in a quantified expression. This is
1891 -- handled below in the expansion of the attribute.
1893 if Attribute_Name
(Parent
(Pref
)) = Name_Old
then
1896 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1899 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
1900 -- containing build-in-place function calls whose returned object covers
1903 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
1904 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
1907 -- If prefix is a protected type name, this is a reference to the
1908 -- current instance of the type. For a component definition, nothing
1909 -- to do (expansion will occur in the init proc). In other contexts,
1910 -- rewrite into reference to current instance.
1912 if Is_Protected_Self_Reference
(Pref
)
1914 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1915 N_Discriminant_Association
)
1916 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1917 N_Component_Definition
)
1919 -- No action needed for these attributes since the current instance
1920 -- will be rewritten to be the name of the _object parameter
1921 -- associated with the enclosing protected subprogram (see below).
1923 and then Id
/= Attribute_Access
1924 and then Id
/= Attribute_Unchecked_Access
1925 and then Id
/= Attribute_Unrestricted_Access
1927 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1931 -- Remaining processing depends on specific attribute
1933 -- Note: individual sections of the following case statement are
1934 -- allowed to assume there is no code after the case statement, and
1935 -- are legitimately allowed to execute return statements if they have
1936 -- nothing more to do.
1940 -- Attributes related to Ada 2012 iterators
1942 when Attribute_Constant_Indexing
1943 | Attribute_Default_Iterator
1944 | Attribute_Implicit_Dereference
1945 | Attribute_Iterable
1946 | Attribute_Iterator_Element
1947 | Attribute_Variable_Indexing
1951 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1952 -- were already rejected by the parser. Thus they shouldn't appear here.
1954 when Internal_Attribute_Id
=>
1955 raise Program_Error
;
1961 when Attribute_Access
1962 | Attribute_Unchecked_Access
1963 | Attribute_Unrestricted_Access
1965 Access_Cases
: declare
1966 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1967 Btyp_DDT
: Entity_Id
;
1969 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1970 -- If N denotes a compound name (selected component, indexed
1971 -- component, or slice), returns the name of the outermost such
1972 -- enclosing object. Otherwise returns N. If the object is a
1973 -- renaming, then the renamed object is returned.
1975 ----------------------
1976 -- Enclosing_Object --
1977 ----------------------
1979 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1984 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1985 N_Indexed_Component
,
1988 Obj_Name
:= Prefix
(Obj_Name
);
1991 return Get_Referenced_Object
(Obj_Name
);
1992 end Enclosing_Object
;
1994 -- Local declarations
1996 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1998 -- Start of processing for Access_Cases
2001 Btyp_DDT
:= Designated_Type
(Btyp
);
2003 -- Handle designated types that come from the limited view
2005 if From_Limited_With
(Btyp_DDT
)
2006 and then Has_Non_Limited_View
(Btyp_DDT
)
2008 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
2011 -- In order to improve the text of error messages, the designated
2012 -- type of access-to-subprogram itypes is set by the semantics as
2013 -- the associated subprogram entity (see sem_attr). Now we replace
2014 -- such node with the proper E_Subprogram_Type itype.
2016 if Id
= Attribute_Unrestricted_Access
2017 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
2019 -- The following conditions ensure that this special management
2020 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2021 -- At this stage other cases in which the designated type is
2022 -- still a subprogram (instead of an E_Subprogram_Type) are
2023 -- wrong because the semantics must have overridden the type of
2024 -- the node with the type imposed by the context.
2026 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
2027 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
2029 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
2033 Subp
: constant Entity_Id
:=
2034 Directly_Designated_Type
(Typ
);
2036 Extra
: Entity_Id
:= Empty
;
2037 New_Formal
: Entity_Id
;
2038 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
2039 Subp_Typ
: Entity_Id
;
2042 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
2043 Set_Etype
(Subp_Typ
, Etype
(Subp
));
2044 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
2046 if Present
(Old_Formal
) then
2047 New_Formal
:= New_Copy
(Old_Formal
);
2048 Set_First_Entity
(Subp_Typ
, New_Formal
);
2051 Set_Scope
(New_Formal
, Subp_Typ
);
2052 Etyp
:= Etype
(New_Formal
);
2054 -- Handle itypes. There is no need to duplicate
2055 -- here the itypes associated with record types
2056 -- (i.e the implicit full view of private types).
2059 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
2061 Extra
:= New_Copy
(Etyp
);
2062 Set_Parent
(Extra
, New_Formal
);
2063 Set_Etype
(New_Formal
, Extra
);
2064 Set_Scope
(Extra
, Subp_Typ
);
2067 Extra
:= New_Formal
;
2068 Next_Formal
(Old_Formal
);
2069 exit when No
(Old_Formal
);
2071 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
2072 Next_Entity
(New_Formal
);
2075 Unlink_Next_Entity
(New_Formal
);
2076 Set_Last_Entity
(Subp_Typ
, Extra
);
2079 -- Now that the explicit formals have been duplicated,
2080 -- any extra formals needed by the subprogram must be
2083 if Present
(Extra
) then
2084 Set_Extra_Formal
(Extra
, Empty
);
2087 Create_Extra_Formals
(Subp_Typ
);
2088 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
2093 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
2094 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
2096 -- If prefix is a type name, this is a reference to the current
2097 -- instance of the type, within its initialization procedure.
2099 elsif Is_Entity_Name
(Pref
)
2100 and then Is_Type
(Entity
(Pref
))
2107 -- If the current instance name denotes a task type, then
2108 -- the access attribute is rewritten to be the name of the
2109 -- "_task" parameter associated with the task type's task
2110 -- procedure. An unchecked conversion is applied to ensure
2111 -- a type match in cases of expander-generated calls (e.g.
2114 if Is_Task_Type
(Entity
(Pref
)) then
2116 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
2117 while Present
(Formal
) loop
2118 exit when Chars
(Formal
) = Name_uTask
;
2119 Next_Entity
(Formal
);
2122 pragma Assert
(Present
(Formal
));
2125 Unchecked_Convert_To
(Typ
,
2126 New_Occurrence_Of
(Formal
, Loc
)));
2129 elsif Is_Protected_Type
(Entity
(Pref
)) then
2131 -- No action needed for current instance located in a
2132 -- component definition (expansion will occur in the
2135 if Is_Protected_Type
(Current_Scope
) then
2138 -- If the current instance reference is located in a
2139 -- protected subprogram or entry then rewrite the access
2140 -- attribute to be the name of the "_object" parameter.
2141 -- An unchecked conversion is applied to ensure a type
2142 -- match in cases of expander-generated calls (e.g. init
2145 -- The code may be nested in a block, so find enclosing
2146 -- scope that is a protected operation.
2153 Subp
:= Current_Scope
;
2154 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
2155 Subp
:= Scope
(Subp
);
2160 (Protected_Body_Subprogram
(Subp
));
2162 -- For a protected subprogram the _Object parameter
2163 -- is the protected record, so we create an access
2164 -- to it. The _Object parameter of an entry is an
2167 if Ekind
(Subp
) = E_Entry
then
2169 Unchecked_Convert_To
(Typ
,
2170 New_Occurrence_Of
(Formal
, Loc
)));
2175 Unchecked_Convert_To
(Typ
,
2176 Make_Attribute_Reference
(Loc
,
2177 Attribute_Name
=> Name_Unrestricted_Access
,
2179 New_Occurrence_Of
(Formal
, Loc
))));
2180 Analyze_And_Resolve
(N
);
2185 -- The expression must appear in a default expression,
2186 -- (which in the initialization procedure is the right-hand
2187 -- side of an assignment), and not in a discriminant
2192 while Present
(Par
) loop
2193 exit when Nkind
(Par
) = N_Assignment_Statement
;
2195 if Nkind
(Par
) = N_Component_Declaration
then
2199 Par
:= Parent
(Par
);
2202 if Present
(Par
) then
2204 Make_Attribute_Reference
(Loc
,
2205 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2206 Attribute_Name
=> Attribute_Name
(N
)));
2208 Analyze_And_Resolve
(N
, Typ
);
2213 -- If the prefix of an Access attribute is a dereference of an
2214 -- access parameter (or a renaming of such a dereference, or a
2215 -- subcomponent of such a dereference) and the context is a
2216 -- general access type (including the type of an object or
2217 -- component with an access_definition, but not the anonymous
2218 -- type of an access parameter or access discriminant), then
2219 -- apply an accessibility check to the access parameter. We used
2220 -- to rewrite the access parameter as a type conversion, but that
2221 -- could only be done if the immediate prefix of the Access
2222 -- attribute was the dereference, and didn't handle cases where
2223 -- the attribute is applied to a subcomponent of the dereference,
2224 -- since there's generally no available, appropriate access type
2225 -- to convert to in that case. The attribute is passed as the
2226 -- point to insert the check, because the access parameter may
2227 -- come from a renaming, possibly in a different scope, and the
2228 -- check must be associated with the attribute itself.
2230 elsif Id
= Attribute_Access
2231 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2232 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2233 and then (Ekind
(Btyp
) = E_General_Access_Type
2234 or else Is_Local_Anonymous_Access
(Btyp
))
2235 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
2236 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2237 = E_Anonymous_Access_Type
2238 and then Present
(Extra_Accessibility
2239 (Entity
(Prefix
(Enc_Object
))))
2241 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2243 -- Ada 2005 (AI-251): If the designated type is an interface we
2244 -- add an implicit conversion to force the displacement of the
2245 -- pointer to reference the secondary dispatch table.
2247 elsif Is_Interface
(Btyp_DDT
)
2248 and then (Comes_From_Source
(N
)
2249 or else Comes_From_Source
(Ref_Object
)
2250 or else (Nkind
(Ref_Object
) in N_Has_Chars
2251 and then Chars
(Ref_Object
) = Name_uInit
))
2253 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2255 -- No implicit conversion required if types match, or if
2256 -- the prefix is the class_wide_type of the interface. In
2257 -- either case passing an object of the interface type has
2258 -- already set the pointer correctly.
2260 if Btyp_DDT
= Etype
(Ref_Object
)
2261 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2263 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2268 Rewrite
(Prefix
(N
),
2269 Convert_To
(Btyp_DDT
,
2270 New_Copy_Tree
(Prefix
(N
))));
2272 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2275 -- When the object is an explicit dereference, convert the
2276 -- dereference's prefix.
2280 Obj_DDT
: constant Entity_Id
:=
2282 (Directly_Designated_Type
2283 (Etype
(Prefix
(Ref_Object
))));
2285 -- No implicit conversion required if designated types
2288 if Obj_DDT
/= Btyp_DDT
2289 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2290 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2294 New_Copy_Tree
(Prefix
(Ref_Object
))));
2295 Analyze_And_Resolve
(N
, Typ
);
2306 -- Transforms 'Adjacent into a call to the floating-point attribute
2307 -- function Adjacent in Fat_xxx (where xxx is the root type)
2309 when Attribute_Adjacent
=>
2310 Expand_Fpt_Attribute_RR
(N
);
2316 when Attribute_Address
=> Address
: declare
2317 Task_Proc
: Entity_Id
;
2319 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean;
2320 -- Returns True if N is being used to initialize a component of
2321 -- an activation record object where the component corresponds to
2322 -- the object denoted by the prefix of the attribute N.
2324 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean is
2326 return Present
(Parent
(N
))
2327 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2328 and then Is_Entity_Name
(Pref
)
2329 and then Present
(Activation_Record_Component
(Entity
(Pref
)))
2330 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2331 and then Entity
(Selector_Name
(Name
(Parent
(N
)))) =
2332 Activation_Record_Component
(Entity
(Pref
));
2333 end Is_Unnested_Component_Init
;
2335 -- Start of processing for Address
2338 -- If the prefix is a task or a task type, the useful address is that
2339 -- of the procedure for the task body, i.e. the actual program unit.
2340 -- We replace the original entity with that of the procedure.
2342 if Is_Entity_Name
(Pref
)
2343 and then Is_Task_Type
(Entity
(Pref
))
2345 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2347 while Present
(Task_Proc
) loop
2348 exit when Ekind
(Task_Proc
) = E_Procedure
2349 and then Etype
(First_Formal
(Task_Proc
)) =
2350 Corresponding_Record_Type
(Ptyp
);
2351 Next_Entity
(Task_Proc
);
2354 if Present
(Task_Proc
) then
2355 Set_Entity
(Pref
, Task_Proc
);
2356 Set_Etype
(Pref
, Etype
(Task_Proc
));
2359 -- Similarly, the address of a protected operation is the address
2360 -- of the corresponding protected body, regardless of the protected
2361 -- object from which it is selected.
2363 elsif Nkind
(Pref
) = N_Selected_Component
2364 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2365 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2369 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2371 elsif Nkind
(Pref
) = N_Explicit_Dereference
2372 and then Ekind
(Ptyp
) = E_Subprogram_Type
2373 and then Convention
(Ptyp
) = Convention_Protected
2375 -- The prefix is be a dereference of an access_to_protected_
2376 -- subprogram. The desired address is the second component of
2377 -- the record that represents the access.
2380 Addr
: constant Entity_Id
:= Etype
(N
);
2381 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2382 T
: constant Entity_Id
:=
2383 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2387 Unchecked_Convert_To
(Addr
,
2388 Make_Selected_Component
(Loc
,
2389 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2390 Selector_Name
=> New_Occurrence_Of
(
2391 Next_Entity
(First_Entity
(T
)), Loc
))));
2393 Analyze_And_Resolve
(N
, Addr
);
2396 -- Ada 2005 (AI-251): Class-wide interface objects are always
2397 -- "displaced" to reference the tag associated with the interface
2398 -- type. In order to obtain the real address of such objects we
2399 -- generate a call to a run-time subprogram that returns the base
2400 -- address of the object. This call is not generated in cases where
2401 -- the attribute is being used to initialize a component of an
2402 -- activation record object where the component corresponds to
2403 -- prefix of the attribute (for back ends that require "unnesting"
2404 -- of nested subprograms), since the address needs to be assigned
2405 -- as-is to such components.
2407 elsif Is_Class_Wide_Type
(Ptyp
)
2408 and then Is_Interface
(Underlying_Type
(Ptyp
))
2409 and then Tagged_Type_Expansion
2410 and then not (Nkind
(Pref
) in N_Has_Entity
2411 and then Is_Subprogram
(Entity
(Pref
)))
2412 and then not Is_Unnested_Component_Init
(N
)
2415 Make_Function_Call
(Loc
,
2416 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2417 Parameter_Associations
=> New_List
(
2418 Relocate_Node
(N
))));
2423 -- Deal with packed array reference, other cases are handled by
2426 if Involves_Packed_Array_Reference
(Pref
) then
2427 Expand_Packed_Address_Reference
(N
);
2435 when Attribute_Alignment
=> Alignment
: declare
2439 -- For class-wide types, X'Class'Alignment is transformed into a
2440 -- direct reference to the Alignment of the class type, so that the
2441 -- back end does not have to deal with the X'Class'Alignment
2444 if Is_Entity_Name
(Pref
)
2445 and then Is_Class_Wide_Type
(Entity
(Pref
))
2447 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2450 -- For x'Alignment applied to an object of a class wide type,
2451 -- transform X'Alignment into a call to the predefined primitive
2452 -- operation _Alignment applied to X.
2454 elsif Is_Class_Wide_Type
(Ptyp
) then
2456 Make_Attribute_Reference
(Loc
,
2458 Attribute_Name
=> Name_Tag
);
2460 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2462 -- Case where the context is a specific integer type with which
2463 -- the original attribute was compatible. The function has a
2464 -- specific type as well, so to preserve the compatibility we
2465 -- must convert explicitly.
2467 if Typ
/= Standard_Integer
then
2468 New_Node
:= Convert_To
(Typ
, New_Node
);
2471 Rewrite
(N
, New_Node
);
2472 Analyze_And_Resolve
(N
, Typ
);
2475 -- For all other cases, we just have to deal with the case of
2476 -- the fact that the result can be universal.
2479 Apply_Universal_Integer_Attribute_Checks
(N
);
2487 -- We compute this if a packed array reference was present, otherwise we
2488 -- leave the computation up to the back end.
2490 when Attribute_Bit
=>
2491 if Involves_Packed_Array_Reference
(Pref
) then
2492 Expand_Packed_Bit_Reference
(N
);
2494 Apply_Universal_Integer_Attribute_Checks
(N
);
2501 -- We compute this if a component clause was present, otherwise we leave
2502 -- the computation up to the back end, since we don't know what layout
2505 -- Note that the attribute can apply to a naked record component
2506 -- in generated code (i.e. the prefix is an identifier that
2507 -- references the component or discriminant entity).
2509 when Attribute_Bit_Position
=> Bit_Position
: declare
2513 if Nkind
(Pref
) = N_Identifier
then
2514 CE
:= Entity
(Pref
);
2516 CE
:= Entity
(Selector_Name
(Pref
));
2519 if Known_Static_Component_Bit_Offset
(CE
) then
2521 Make_Integer_Literal
(Loc
,
2522 Intval
=> Component_Bit_Offset
(CE
)));
2523 Analyze_And_Resolve
(N
, Typ
);
2526 Apply_Universal_Integer_Attribute_Checks
(N
);
2534 -- A reference to P'Body_Version or P'Version is expanded to
2537 -- pragma Import (C, Vnn, "uuuuT");
2539 -- Get_Version_String (Vnn)
2541 -- where uuuu is the unit name (dots replaced by double underscore)
2542 -- and T is B for the cases of Body_Version, or Version applied to a
2543 -- subprogram acting as its own spec, and S for Version applied to a
2544 -- subprogram spec or package. This sequence of code references the
2545 -- unsigned constant created in the main program by the binder.
2547 -- A special exception occurs for Standard, where the string returned
2548 -- is a copy of the library string in gnatvsn.ads.
2550 when Attribute_Body_Version
2554 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2559 -- If not library unit, get to containing library unit
2561 Pent
:= Entity
(Pref
);
2562 while Pent
/= Standard_Standard
2563 and then Scope
(Pent
) /= Standard_Standard
2564 and then not Is_Child_Unit
(Pent
)
2566 Pent
:= Scope
(Pent
);
2569 -- Special case Standard and Standard.ASCII
2571 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2573 Make_String_Literal
(Loc
,
2574 Strval
=> Verbose_Library_Version
));
2579 -- Build required string constant
2581 Get_Name_String
(Get_Unit_Name
(Pent
));
2584 for J
in 1 .. Name_Len
- 2 loop
2585 if Name_Buffer
(J
) = '.' then
2586 Store_String_Chars
("__");
2588 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2592 -- Case of subprogram acting as its own spec, always use body
2594 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2595 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2597 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2599 Store_String_Chars
("B");
2601 -- Case of no body present, always use spec
2603 elsif not Unit_Requires_Body
(Pent
) then
2604 Store_String_Chars
("S");
2606 -- Otherwise use B for Body_Version, S for spec
2608 elsif Id
= Attribute_Body_Version
then
2609 Store_String_Chars
("B");
2611 Store_String_Chars
("S");
2615 Lib
.Version_Referenced
(S
);
2617 -- Insert the object declaration
2619 Insert_Actions
(N
, New_List
(
2620 Make_Object_Declaration
(Loc
,
2621 Defining_Identifier
=> E
,
2622 Object_Definition
=>
2623 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2625 -- Set entity as imported with correct external name
2627 Set_Is_Imported
(E
);
2628 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2630 -- Set entity as internal to ensure proper Sprint output of its
2631 -- implicit importation.
2633 Set_Is_Internal
(E
);
2635 -- And now rewrite original reference
2638 Make_Function_Call
(Loc
,
2640 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2641 Parameter_Associations
=> New_List
(
2642 New_Occurrence_Of
(E
, Loc
))));
2645 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2652 -- Transforms 'Ceiling into a call to the floating-point attribute
2653 -- function Ceiling in Fat_xxx (where xxx is the root type)
2655 when Attribute_Ceiling
=>
2656 Expand_Fpt_Attribute_R
(N
);
2662 -- Transforms 'Callable attribute into a call to the Callable function
2664 when Attribute_Callable
=>
2666 -- We have an object of a task interface class-wide type as a prefix
2667 -- to Callable. Generate:
2668 -- callable (Task_Id (Pref._disp_get_task_id));
2670 if Ada_Version
>= Ada_2005
2671 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2672 and then Is_Interface
(Ptyp
)
2673 and then Is_Task_Interface
(Ptyp
)
2676 Make_Function_Call
(Loc
,
2678 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2679 Parameter_Associations
=> New_List
(
2680 Make_Unchecked_Type_Conversion
(Loc
,
2682 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2683 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
2686 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2689 Analyze_And_Resolve
(N
, Standard_Boolean
);
2695 -- Transforms 'Caller attribute into a call to either the
2696 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2698 when Attribute_Caller
=> Caller
: declare
2699 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2700 Ent
: constant Entity_Id
:= Entity
(Pref
);
2701 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2702 Nest_Depth
: Integer := 0;
2709 if Is_Protected_Type
(Conctype
) then
2710 case Corresponding_Runtime_Package
(Conctype
) is
2711 when System_Tasking_Protected_Objects_Entries
=>
2714 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2716 when System_Tasking_Protected_Objects_Single_Entry
=>
2719 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2722 raise Program_Error
;
2726 Unchecked_Convert_To
(Id_Kind
,
2727 Make_Function_Call
(Loc
,
2729 Parameter_Associations
=> New_List
(
2731 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2736 -- Determine the nesting depth of the E'Caller attribute, that
2737 -- is, how many accept statements are nested within the accept
2738 -- statement for E at the point of E'Caller. The runtime uses
2739 -- this depth to find the specified entry call.
2741 for J
in reverse 0 .. Scope_Stack
.Last
loop
2742 S
:= Scope_Stack
.Table
(J
).Entity
;
2744 -- We should not reach the scope of the entry, as it should
2745 -- already have been checked in Sem_Attr that this attribute
2746 -- reference is within a matching accept statement.
2748 pragma Assert
(S
/= Conctype
);
2753 elsif Is_Entry
(S
) then
2754 Nest_Depth
:= Nest_Depth
+ 1;
2759 Unchecked_Convert_To
(Id_Kind
,
2760 Make_Function_Call
(Loc
,
2762 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2763 Parameter_Associations
=> New_List
(
2764 Make_Integer_Literal
(Loc
,
2765 Intval
=> Int
(Nest_Depth
))))));
2768 Analyze_And_Resolve
(N
, Id_Kind
);
2775 -- Transforms 'Compose into a call to the floating-point attribute
2776 -- function Compose in Fat_xxx (where xxx is the root type)
2778 -- Note: we strictly should have special code here to deal with the
2779 -- case of absurdly negative arguments (less than Integer'First)
2780 -- which will return a (signed) zero value, but it hardly seems
2781 -- worth the effort. Absurdly large positive arguments will raise
2782 -- constraint error which is fine.
2784 when Attribute_Compose
=>
2785 Expand_Fpt_Attribute_RI
(N
);
2791 when Attribute_Constrained
=> Constrained
: declare
2792 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2794 -- Start of processing for Constrained
2797 -- Reference to a parameter where the value is passed as an extra
2798 -- actual, corresponding to the extra formal referenced by the
2799 -- Extra_Constrained field of the corresponding formal. If this
2800 -- is an entry in-parameter, it is replaced by a constant renaming
2801 -- for which Extra_Constrained is never created.
2803 if Present
(Formal_Ent
)
2804 and then Ekind
(Formal_Ent
) /= E_Constant
2805 and then Present
(Extra_Constrained
(Formal_Ent
))
2809 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2811 -- If the prefix is an access to object, the attribute applies to
2812 -- the designated object, so rewrite with an explicit dereference.
2814 elsif Is_Access_Type
(Etype
(Pref
))
2816 (not Is_Entity_Name
(Pref
) or else Is_Object
(Entity
(Pref
)))
2819 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Pref
)));
2820 Analyze_And_Resolve
(N
, Standard_Boolean
);
2823 -- For variables with a Extra_Constrained field, we use the
2824 -- corresponding entity.
2826 elsif Nkind
(Pref
) = N_Identifier
2827 and then Ekind
(Entity
(Pref
)) = E_Variable
2828 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2832 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2834 -- For all other cases, we can tell at compile time
2837 -- For access type, apply access check as needed
2839 if Is_Entity_Name
(Pref
)
2840 and then not Is_Type
(Entity
(Pref
))
2841 and then Is_Access_Type
(Ptyp
)
2843 Apply_Access_Check
(N
);
2849 (Exp_Util
.Attribute_Constrained_Static_Value
2850 (Pref
)), Sloc
(N
)));
2853 Analyze_And_Resolve
(N
, Standard_Boolean
);
2860 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2861 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2863 when Attribute_Copy_Sign
=>
2864 Expand_Fpt_Attribute_RR
(N
);
2870 -- Transforms 'Count attribute into a call to the Count function
2872 when Attribute_Count
=> Count
: declare
2874 Conctyp
: Entity_Id
;
2876 Entry_Id
: Entity_Id
;
2881 -- If the prefix is a member of an entry family, retrieve both
2882 -- entry name and index. For a simple entry there is no index.
2884 if Nkind
(Pref
) = N_Indexed_Component
then
2885 Entnam
:= Prefix
(Pref
);
2886 Index
:= First
(Expressions
(Pref
));
2892 Entry_Id
:= Entity
(Entnam
);
2894 -- Find the concurrent type in which this attribute is referenced
2895 -- (there had better be one).
2897 Conctyp
:= Current_Scope
;
2898 while not Is_Concurrent_Type
(Conctyp
) loop
2899 Conctyp
:= Scope
(Conctyp
);
2904 if Is_Protected_Type
(Conctyp
) then
2906 -- No need to transform 'Count into a function call if the current
2907 -- scope has been eliminated. In this case such transformation is
2908 -- also not viable because the enclosing protected object is not
2911 if Is_Eliminated
(Current_Scope
) then
2915 case Corresponding_Runtime_Package
(Conctyp
) is
2916 when System_Tasking_Protected_Objects_Entries
=>
2917 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
2920 Make_Function_Call
(Loc
,
2922 Parameter_Associations
=> New_List
(
2924 (Find_Protection_Object
(Current_Scope
), Loc
),
2925 Entry_Index_Expression
2926 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2928 when System_Tasking_Protected_Objects_Single_Entry
=>
2930 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
2933 Make_Function_Call
(Loc
,
2935 Parameter_Associations
=> New_List
(
2937 (Find_Protection_Object
(Current_Scope
), Loc
)));
2940 raise Program_Error
;
2947 Make_Function_Call
(Loc
,
2948 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
2949 Parameter_Associations
=> New_List
(
2950 Entry_Index_Expression
(Loc
,
2951 Entry_Id
, Index
, Scope
(Entry_Id
))));
2954 -- The call returns type Natural but the context is universal integer
2955 -- so any integer type is allowed. The attribute was already resolved
2956 -- so its Etype is the required result type. If the base type of the
2957 -- context type is other than Standard.Integer we put in a conversion
2958 -- to the required type. This can be a normal typed conversion since
2959 -- both input and output types of the conversion are integer types
2961 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2962 Rewrite
(N
, Convert_To
(Typ
, Call
));
2967 Analyze_And_Resolve
(N
, Typ
);
2970 ---------------------
2971 -- Descriptor_Size --
2972 ---------------------
2974 when Attribute_Descriptor_Size
=>
2976 -- Attribute Descriptor_Size is handled by the back end when applied
2977 -- to an unconstrained array type.
2979 if Is_Array_Type
(Ptyp
)
2980 and then not Is_Constrained
(Ptyp
)
2982 Apply_Universal_Integer_Attribute_Checks
(N
);
2984 -- For any other type, the descriptor size is 0 because there is no
2985 -- actual descriptor, but the result is not formally static.
2988 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2990 Set_Is_Static_Expression
(N
, False);
2997 -- This processing is shared by Elab_Spec
2999 -- What we do is to insert the following declarations
3002 -- pragma Import (C, enn, "name___elabb/s");
3004 -- and then the Elab_Body/Spec attribute is replaced by a reference
3005 -- to this defining identifier.
3007 when Attribute_Elab_Body
3008 | Attribute_Elab_Spec
3010 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3011 -- back-end knows how to handle these attributes directly.
3013 if CodePeer_Mode
then
3018 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
3022 procedure Make_Elab_String
(Nod
: Node_Id
);
3023 -- Given Nod, an identifier, or a selected component, put the
3024 -- image into the current string literal, with double underline
3025 -- between components.
3027 ----------------------
3028 -- Make_Elab_String --
3029 ----------------------
3031 procedure Make_Elab_String
(Nod
: Node_Id
) is
3033 if Nkind
(Nod
) = N_Selected_Component
then
3034 Make_Elab_String
(Prefix
(Nod
));
3035 Store_String_Char
('_');
3036 Store_String_Char
('_');
3037 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
3040 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
3041 Get_Name_String
(Chars
(Nod
));
3044 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3045 end Make_Elab_String
;
3047 -- Start of processing for Elab_Body/Elab_Spec
3050 -- First we need to prepare the string literal for the name of
3051 -- the elaboration routine to be referenced.
3054 Make_Elab_String
(Pref
);
3055 Store_String_Chars
("___elab");
3056 Lang
:= Make_Identifier
(Loc
, Name_C
);
3058 if Id
= Attribute_Elab_Body
then
3059 Store_String_Char
('b');
3061 Store_String_Char
('s');
3066 Insert_Actions
(N
, New_List
(
3067 Make_Subprogram_Declaration
(Loc
,
3069 Make_Procedure_Specification
(Loc
,
3070 Defining_Unit_Name
=> Ent
)),
3073 Chars
=> Name_Import
,
3074 Pragma_Argument_Associations
=> New_List
(
3075 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3077 Make_Pragma_Argument_Association
(Loc
,
3078 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3080 Make_Pragma_Argument_Association
(Loc
,
3081 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3083 Set_Entity
(N
, Ent
);
3084 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3087 --------------------
3088 -- Elab_Subp_Body --
3089 --------------------
3091 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3092 -- this attribute directly, and if we are not in CodePeer mode it is
3093 -- entirely ignored ???
3095 when Attribute_Elab_Subp_Body
=>
3102 -- Elaborated is always True for preelaborated units, predefined units,
3103 -- pure units and units which have Elaborate_Body pragmas. These units
3104 -- have no elaboration entity.
3106 -- Note: The Elaborated attribute is never passed to the back end
3108 when Attribute_Elaborated
=> Elaborated
: declare
3109 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3112 if Present
(Elab_Id
) then
3115 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3116 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3118 Analyze_And_Resolve
(N
, Typ
);
3120 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3128 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3132 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3135 if Is_Non_Empty_List
(Exprs
) then
3136 Expr
:= First
(Exprs
);
3141 -- If the expression is an enumeration literal, it is replaced by the
3144 if Nkind
(Expr
) in N_Has_Entity
3145 and then Ekind
(Entity
(Expr
)) = E_Enumeration_Literal
3148 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Expr
))));
3150 -- If this is a renaming of a literal, recover the representation
3151 -- of the original. If it renames an expression there is nothing to
3154 elsif Nkind
(Expr
) in N_Has_Entity
3155 and then Ekind
(Entity
(Expr
)) = E_Constant
3156 and then Present
(Renamed_Object
(Entity
(Expr
)))
3157 and then Is_Entity_Name
(Renamed_Object
(Entity
(Expr
)))
3158 and then Ekind
(Entity
(Renamed_Object
(Entity
(Expr
)))) =
3159 E_Enumeration_Literal
3162 Make_Integer_Literal
(Loc
,
3163 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Expr
))))));
3165 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3166 -- X'Enum_Rep expands to
3170 -- This is simply a direct conversion from the enumeration type to
3171 -- the target integer type, which is treated by the back end as a
3172 -- normal integer conversion, treating the enumeration type as an
3173 -- integer, which is exactly what we want. We set Conversion_OK to
3174 -- make sure that the analyzer does not complain about what otherwise
3175 -- might be an illegal conversion.
3178 Rewrite
(N
, OK_Convert_To
(Typ
, Relocate_Node
(Expr
)));
3182 Analyze_And_Resolve
(N
, Typ
);
3189 when Attribute_Enum_Val
=> Enum_Val
: declare
3191 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3194 -- X'Enum_Val (Y) expands to
3196 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3199 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3201 -- Ensure that the expression is not truncated since the "bad" bits
3204 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
3205 Set_No_Truncation
(Expr
);
3209 Make_Raise_Constraint_Error
(Loc
,
3213 Make_Function_Call
(Loc
,
3215 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3216 Parameter_Associations
=> New_List
(
3217 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3218 New_Occurrence_Of
(Standard_False
, Loc
))),
3220 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3221 Reason
=> CE_Range_Check_Failed
));
3224 Analyze_And_Resolve
(N
, Ptyp
);
3231 -- Transforms 'Exponent into a call to the floating-point attribute
3232 -- function Exponent in Fat_xxx (where xxx is the root type)
3234 when Attribute_Exponent
=>
3235 Expand_Fpt_Attribute_R
(N
);
3241 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3243 when Attribute_External_Tag
=>
3245 Make_Function_Call
(Loc
,
3247 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3248 Parameter_Associations
=> New_List
(
3249 Make_Attribute_Reference
(Loc
,
3250 Attribute_Name
=> Name_Tag
,
3251 Prefix
=> Prefix
(N
)))));
3253 Analyze_And_Resolve
(N
, Standard_String
);
3255 -----------------------
3256 -- Finalization_Size --
3257 -----------------------
3259 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3260 function Calculate_Header_Size
return Node_Id
;
3261 -- Generate a runtime call to calculate the size of the hidden header
3262 -- along with any added padding which would precede a heap-allocated
3263 -- object of the prefix type.
3265 ---------------------------
3266 -- Calculate_Header_Size --
3267 ---------------------------
3269 function Calculate_Header_Size
return Node_Id
is
3272 -- Universal_Integer
3273 -- (Header_Size_With_Padding (Pref'Alignment))
3276 Convert_To
(Universal_Integer
,
3277 Make_Function_Call
(Loc
,
3279 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3281 Parameter_Associations
=> New_List
(
3282 Make_Attribute_Reference
(Loc
,
3283 Prefix
=> New_Copy_Tree
(Pref
),
3284 Attribute_Name
=> Name_Alignment
))));
3285 end Calculate_Header_Size
;
3291 -- Start of Finalization_Size
3294 -- An object of a class-wide type first requires a runtime check to
3295 -- determine whether it is actually controlled or not. Depending on
3296 -- the outcome of this check, the Finalization_Size of the object
3297 -- may be zero or some positive value.
3299 -- In this scenario, Pref'Finalization_Size is expanded into
3301 -- Size : Integer := 0;
3303 -- if Needs_Finalization (Pref'Tag) then
3305 -- Universal_Integer
3306 -- (Header_Size_With_Padding (Pref'Alignment));
3309 -- and the attribute reference is replaced with a reference to Size.
3311 if Is_Class_Wide_Type
(Ptyp
) then
3312 Size
:= Make_Temporary
(Loc
, 'S');
3314 Insert_Actions
(N
, New_List
(
3317 -- Size : Integer := 0;
3319 Make_Object_Declaration
(Loc
,
3320 Defining_Identifier
=> Size
,
3321 Object_Definition
=>
3322 New_Occurrence_Of
(Standard_Integer
, Loc
),
3323 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3326 -- if Needs_Finalization (Pref'Tag) then
3328 -- Universal_Integer
3329 -- (Header_Size_With_Padding (Pref'Alignment));
3332 Make_If_Statement
(Loc
,
3334 Make_Function_Call
(Loc
,
3336 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3338 Parameter_Associations
=> New_List
(
3339 Make_Attribute_Reference
(Loc
,
3340 Prefix
=> New_Copy_Tree
(Pref
),
3341 Attribute_Name
=> Name_Tag
))),
3343 Then_Statements
=> New_List
(
3344 Make_Assignment_Statement
(Loc
,
3345 Name
=> New_Occurrence_Of
(Size
, Loc
),
3346 Expression
=> Calculate_Header_Size
)))));
3348 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3350 -- The prefix is known to be controlled at compile time. Calculate
3351 -- Finalization_Size by calling function Header_Size_With_Padding.
3353 elsif Needs_Finalization
(Ptyp
) then
3354 Rewrite
(N
, Calculate_Header_Size
);
3356 -- The prefix is not an object with controlled parts, so its
3357 -- Finalization_Size is zero.
3360 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3363 -- Due to cases where the entity type of the attribute is already
3364 -- resolved the rewritten N must get re-resolved to its appropriate
3367 Analyze_And_Resolve
(N
, Typ
);
3368 end Finalization_Size
;
3374 when Attribute_First
=>
3376 -- If the prefix type is a constrained packed array type which
3377 -- already has a Packed_Array_Impl_Type representation defined, then
3378 -- replace this attribute with a direct reference to 'First of the
3379 -- appropriate index subtype (since otherwise the back end will try
3380 -- to give us the value of 'First for this implementation type).
3382 if Is_Constrained_Packed_Array
(Ptyp
) then
3384 Make_Attribute_Reference
(Loc
,
3385 Attribute_Name
=> Name_First
,
3387 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3388 Analyze_And_Resolve
(N
, Typ
);
3390 -- For access type, apply access check as needed
3392 elsif Is_Access_Type
(Ptyp
) then
3393 Apply_Access_Check
(N
);
3395 -- For scalar type, if low bound is a reference to an entity, just
3396 -- replace with a direct reference. Note that we can only have a
3397 -- reference to a constant entity at this stage, anything else would
3398 -- have already been rewritten.
3400 elsif Is_Scalar_Type
(Ptyp
) then
3402 Lo
: constant Node_Id
:= Type_Low_Bound
(Ptyp
);
3404 if Is_Entity_Name
(Lo
) then
3405 Rewrite
(N
, New_Occurrence_Of
(Entity
(Lo
), Loc
));
3414 -- Compute this if component clause was present, otherwise we leave the
3415 -- computation to be completed in the back-end, since we don't know what
3416 -- layout will be chosen.
3418 when Attribute_First_Bit
=> First_Bit_Attr
: declare
3419 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3422 -- In Ada 2005 (or later) if we have the non-default bit order, then
3423 -- we return the original value as given in the component clause
3424 -- (RM 2005 13.5.2(3/2)).
3426 if Present
(Component_Clause
(CE
))
3427 and then Ada_Version
>= Ada_2005
3428 and then Reverse_Bit_Order
(Scope
(CE
))
3431 Make_Integer_Literal
(Loc
,
3432 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
3433 Analyze_And_Resolve
(N
, Typ
);
3435 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3436 -- rewrite with normalized value if we know it statically.
3438 elsif Known_Static_Component_Bit_Offset
(CE
) then
3440 Make_Integer_Literal
(Loc
,
3441 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
3442 Analyze_And_Resolve
(N
, Typ
);
3444 -- Otherwise left to back end, just do universal integer checks
3447 Apply_Universal_Integer_Attribute_Checks
(N
);
3451 --------------------------------
3452 -- Fixed_Value, Integer_Value --
3453 --------------------------------
3457 -- fixtype'Fixed_Value (integer-value)
3458 -- inttype'Integer_Value (fixed-value)
3462 -- fixtype (integer-value)
3463 -- inttype (fixed-value)
3467 -- We set Conversion_OK on the conversion because we do not want it
3468 -- to go through the fixed-point conversion circuits.
3470 when Attribute_Fixed_Value
3471 | Attribute_Integer_Value
3473 Rewrite
(N
, OK_Convert_To
(Entity
(Pref
), First
(Exprs
)));
3475 -- Note that it might appear that a properly analyzed unchecked
3476 -- conversion would be just fine here, but that's not the case,
3477 -- since the full range checks performed by the following calls
3480 Apply_Type_Conversion_Checks
(N
);
3482 -- Note that Apply_Type_Conversion_Checks only deals with the
3483 -- overflow checks on conversions involving fixed-point types
3484 -- so we must apply range checks manually on them and expand.
3486 Apply_Scalar_Range_Check
3487 (Expression
(N
), Etype
(N
), Fixed_Int
=> True);
3496 -- Transforms 'Floor into a call to the floating-point attribute
3497 -- function Floor in Fat_xxx (where xxx is the root type)
3499 when Attribute_Floor
=>
3500 Expand_Fpt_Attribute_R
(N
);
3506 -- For the fixed-point type Typ:
3512 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3513 -- Universal_Real (Type'Last))
3515 -- Note that we know that the type is a nonstatic subtype, or Fore would
3516 -- have itself been computed dynamically in Eval_Attribute.
3518 when Attribute_Fore
=>
3521 Make_Function_Call
(Loc
,
3523 New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
3525 Parameter_Associations
=> New_List
(
3526 Convert_To
(Universal_Real
,
3527 Make_Attribute_Reference
(Loc
,
3528 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3529 Attribute_Name
=> Name_First
)),
3531 Convert_To
(Universal_Real
,
3532 Make_Attribute_Reference
(Loc
,
3533 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3534 Attribute_Name
=> Name_Last
))))));
3536 Analyze_And_Resolve
(N
, Typ
);
3542 -- Transforms 'Fraction into a call to the floating-point attribute
3543 -- function Fraction in Fat_xxx (where xxx is the root type)
3545 when Attribute_Fraction
=>
3546 Expand_Fpt_Attribute_R
(N
);
3552 when Attribute_From_Any
=> From_Any
: declare
3553 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3554 Decls
: constant List_Id
:= New_List
;
3558 Build_From_Any_Call
(P_Type
,
3559 Relocate_Node
(First
(Exprs
)),
3561 Insert_Actions
(N
, Decls
);
3562 Analyze_And_Resolve
(N
, P_Type
);
3565 ----------------------
3566 -- Has_Same_Storage --
3567 ----------------------
3569 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3570 Loc
: constant Source_Ptr
:= Sloc
(N
);
3572 X
: constant Node_Id
:= Prefix
(N
);
3573 Y
: constant Node_Id
:= First
(Expressions
(N
));
3578 -- Rhe expressions for their addresses
3582 -- Rhe expressions for their sizes
3585 -- The attribute is expanded as:
3587 -- (X'address = Y'address)
3588 -- and then (X'Size = Y'Size)
3590 -- If both arguments have the same Etype the second conjunct can be
3594 Make_Attribute_Reference
(Loc
,
3595 Attribute_Name
=> Name_Address
,
3596 Prefix
=> New_Copy_Tree
(X
));
3599 Make_Attribute_Reference
(Loc
,
3600 Attribute_Name
=> Name_Address
,
3601 Prefix
=> New_Copy_Tree
(Y
));
3604 Make_Attribute_Reference
(Loc
,
3605 Attribute_Name
=> Name_Size
,
3606 Prefix
=> New_Copy_Tree
(X
));
3609 Make_Attribute_Reference
(Loc
,
3610 Attribute_Name
=> Name_Size
,
3611 Prefix
=> New_Copy_Tree
(Y
));
3613 if Etype
(X
) = Etype
(Y
) then
3616 Left_Opnd
=> X_Addr
,
3617 Right_Opnd
=> Y_Addr
));
3623 Left_Opnd
=> X_Addr
,
3624 Right_Opnd
=> Y_Addr
),
3627 Left_Opnd
=> X_Size
,
3628 Right_Opnd
=> Y_Size
)));
3631 Analyze_And_Resolve
(N
, Standard_Boolean
);
3632 end Has_Same_Storage
;
3638 -- For an exception returns a reference to the exception data:
3639 -- Exception_Id!(Prefix'Reference)
3641 -- For a task it returns a reference to the _task_id component of
3642 -- corresponding record:
3644 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3646 -- in Ada.Task_Identification
3648 when Attribute_Identity
=> Identity
: declare
3649 Id_Kind
: Entity_Id
;
3652 if Ptyp
= Standard_Exception_Type
then
3653 Id_Kind
:= RTE
(RE_Exception_Id
);
3655 if Present
(Renamed_Object
(Entity
(Pref
))) then
3656 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3660 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3662 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3664 -- If the prefix is a task interface, the Task_Id is obtained
3665 -- dynamically through a dispatching call, as for other task
3666 -- attributes applied to interfaces.
3668 if Ada_Version
>= Ada_2005
3669 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3670 and then Is_Interface
(Ptyp
)
3671 and then Is_Task_Interface
(Ptyp
)
3674 Unchecked_Convert_To
3675 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
3679 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3683 Analyze_And_Resolve
(N
, Id_Kind
);
3690 -- Image attribute is handled in separate unit Exp_Imgv
3692 when Attribute_Image
=>
3694 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3695 -- back-end knows how to handle this attribute directly.
3697 if CodePeer_Mode
then
3701 Expand_Image_Attribute
(N
);
3707 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3709 when Attribute_Img
=>
3710 Expand_Image_Attribute
(N
);
3716 when Attribute_Input
=> Input
: declare
3717 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3718 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3719 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3720 Strm
: constant Node_Id
:= First
(Exprs
);
3728 Cntrl
: Node_Id
:= Empty
;
3729 -- Value for controlling argument in call. Always Empty except in
3730 -- the dispatching (class-wide type) case, where it is a reference
3731 -- to the dummy object initialized to the right internal tag.
3733 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3734 -- The expansion of the attribute reference may generate a call to
3735 -- a user-defined stream subprogram that is frozen by the call. This
3736 -- can lead to access-before-elaboration problem if the reference
3737 -- appears in an object declaration and the subprogram body has not
3738 -- been seen. The freezing of the subprogram requires special code
3739 -- because it appears in an expanded context where expressions do
3740 -- not freeze their constituents.
3742 ------------------------------
3743 -- Freeze_Stream_Subprogram --
3744 ------------------------------
3746 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3747 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3751 -- If this is user-defined subprogram, the corresponding
3752 -- stream function appears as a renaming-as-body, and the
3753 -- user subprogram must be retrieved by tree traversal.
3756 and then Nkind
(Decl
) = N_Subprogram_Declaration
3757 and then Present
(Corresponding_Body
(Decl
))
3759 Bod
:= Corresponding_Body
(Decl
);
3761 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3762 N_Subprogram_Renaming_Declaration
3764 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3767 end Freeze_Stream_Subprogram
;
3769 -- Start of processing for Input
3772 -- If no underlying type, we have an error that will be diagnosed
3773 -- elsewhere, so here we just completely ignore the expansion.
3779 -- Stream operations can appear in user code even if the restriction
3780 -- No_Streams is active (for example, when instantiating a predefined
3781 -- container). In that case rewrite the attribute as a Raise to
3782 -- prevent any run-time use.
3784 if Restriction_Active
(No_Streams
) then
3786 Make_Raise_Program_Error
(Sloc
(N
),
3787 Reason
=> PE_Stream_Operation_Not_Allowed
));
3788 Set_Etype
(N
, B_Type
);
3792 -- If there is a TSS for Input, just call it
3794 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3796 if Present
(Fname
) then
3800 -- If there is a Stream_Convert pragma, use it, we rewrite
3802 -- sourcetyp'Input (stream)
3806 -- sourcetyp (streamread (strmtyp'Input (stream)));
3808 -- where streamread is the given Read function that converts an
3809 -- argument of type strmtyp to type sourcetyp or a type from which
3810 -- it is derived (extra conversion required for the derived case).
3812 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3814 if Present
(Prag
) then
3815 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3816 Rfunc
:= Entity
(Expression
(Arg2
));
3820 Make_Function_Call
(Loc
,
3821 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3822 Parameter_Associations
=> New_List
(
3823 Make_Attribute_Reference
(Loc
,
3826 (Etype
(First_Formal
(Rfunc
)), Loc
),
3827 Attribute_Name
=> Name_Input
,
3828 Expressions
=> Exprs
)))));
3830 Analyze_And_Resolve
(N
, B_Type
);
3835 elsif Is_Elementary_Type
(U_Type
) then
3837 -- A special case arises if we have a defined _Read routine,
3838 -- since in this case we are required to call this routine.
3841 Typ
: Entity_Id
:= P_Type
;
3843 if Present
(Full_View
(Typ
)) then
3844 Typ
:= Full_View
(Typ
);
3847 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Read
)) then
3848 Build_Record_Or_Elementary_Input_Function
3849 (Loc
, Typ
, Decl
, Fname
, Use_Underlying
=> False);
3850 Insert_Action
(N
, Decl
);
3852 -- For normal cases, we call the I_xxx routine directly
3855 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3856 Analyze_And_Resolve
(N
, P_Type
);
3863 elsif Is_Array_Type
(U_Type
) then
3864 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3865 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3867 -- Dispatching case with class-wide type
3869 elsif Is_Class_Wide_Type
(P_Type
) then
3871 -- No need to do anything else compiling under restriction
3872 -- No_Dispatching_Calls. During the semantic analysis we
3873 -- already notified such violation.
3875 if Restriction_Active
(No_Dispatching_Calls
) then
3880 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3882 Expr
: Node_Id
; -- call to Descendant_Tag
3883 Get_Tag
: Node_Id
; -- expression to read the 'Tag
3886 -- Read the internal tag (RM 13.13.2(34)) and use it to
3887 -- initialize a dummy tag value. We used to unconditionally
3890 -- Descendant_Tag (String'Input (Strm), P_Type);
3892 -- which turns into a call to String_Input_Blk_IO. However,
3893 -- if the input is malformed, that could try to read an
3894 -- enormous String, causing chaos. So instead we call
3895 -- String_Input_Tag, which does the same thing as
3896 -- String_Input_Blk_IO, except that if the String is
3897 -- absurdly long, it raises an exception.
3899 -- However, if the No_Stream_Optimizations restriction
3900 -- is active, we disable this unnecessary attempt at
3901 -- robustness; we really need to read the string
3902 -- character-by-character.
3904 -- This value is used only to provide a controlling
3905 -- argument for the eventual _Input call. Descendant_Tag is
3906 -- called rather than Internal_Tag to ensure that we have a
3907 -- tag for a type that is descended from the prefix type and
3908 -- declared at the same accessibility level (the exception
3909 -- Tag_Error will be raised otherwise). The level check is
3910 -- required for Ada 2005 because tagged types can be
3911 -- extended in nested scopes (AI-344).
3913 -- Note: we used to generate an explicit declaration of a
3914 -- constant Ada.Tags.Tag object, and use an occurrence of
3915 -- this constant in Cntrl, but this caused a secondary stack
3918 if Restriction_Active
(No_Stream_Optimizations
) then
3920 Make_Attribute_Reference
(Loc
,
3922 New_Occurrence_Of
(Standard_String
, Loc
),
3923 Attribute_Name
=> Name_Input
,
3924 Expressions
=> New_List
(
3925 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
3928 Make_Function_Call
(Loc
,
3931 (RTE
(RE_String_Input_Tag
), Loc
),
3932 Parameter_Associations
=> New_List
(
3933 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
3937 Make_Function_Call
(Loc
,
3939 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3940 Parameter_Associations
=> New_List
(
3942 Make_Attribute_Reference
(Loc
,
3943 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
3944 Attribute_Name
=> Name_Tag
)));
3946 Set_Etype
(Expr
, RTE
(RE_Tag
));
3948 -- Now we need to get the entity for the call, and construct
3949 -- a function call node, where we preset a reference to Dnn
3950 -- as the controlling argument (doing an unchecked convert
3951 -- to the class-wide tagged type to make it look like a real
3954 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3955 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
3956 Set_Etype
(Cntrl
, P_Type
);
3957 Set_Parent
(Cntrl
, N
);
3960 -- For tagged types, use the primitive Input function
3962 elsif Is_Tagged_Type
(U_Type
) then
3963 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3965 -- All other record type cases, including protected records. The
3966 -- latter only arise for expander generated code for handling
3967 -- shared passive partition access.
3971 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3973 -- Ada 2005 (AI-216): Program_Error is raised executing default
3974 -- implementation of the Input attribute of an unchecked union
3975 -- type if the type lacks default discriminant values.
3977 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3978 and then No
(Discriminant_Constraint
(U_Type
))
3981 Make_Raise_Program_Error
(Loc
,
3982 Reason
=> PE_Unchecked_Union_Restriction
));
3987 -- Build the type's Input function, passing the subtype rather
3988 -- than its base type, because checks are needed in the case of
3989 -- constrained discriminants (see Ada 2012 AI05-0192).
3991 Build_Record_Or_Elementary_Input_Function
3992 (Loc
, U_Type
, Decl
, Fname
);
3993 Insert_Action
(N
, Decl
);
3995 if Nkind
(Parent
(N
)) = N_Object_Declaration
3996 and then Is_Record_Type
(U_Type
)
3998 -- The stream function may contain calls to user-defined
3999 -- Read procedures for individual components.
4006 Comp
:= First_Component
(U_Type
);
4007 while Present
(Comp
) loop
4009 Find_Stream_Subprogram
4010 (Etype
(Comp
), TSS_Stream_Read
);
4012 if Present
(Func
) then
4013 Freeze_Stream_Subprogram
(Func
);
4016 Next_Component
(Comp
);
4023 -- If we fall through, Fname is the function to be called. The result
4024 -- is obtained by calling the appropriate function, then converting
4025 -- the result. The conversion does a subtype check.
4028 Make_Function_Call
(Loc
,
4029 Name
=> New_Occurrence_Of
(Fname
, Loc
),
4030 Parameter_Associations
=> New_List
(
4031 Relocate_Node
(Strm
)));
4033 Set_Controlling_Argument
(Call
, Cntrl
);
4034 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
4035 Analyze_And_Resolve
(N
, P_Type
);
4037 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4038 Freeze_Stream_Subprogram
(Fname
);
4046 when Attribute_Invalid_Value
=>
4047 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
4049 -- The value produced may be a conversion of a literal, which must be
4050 -- resolved to establish its proper type.
4052 Analyze_And_Resolve
(N
);
4058 when Attribute_Last
=>
4060 -- If the prefix type is a constrained packed array type which
4061 -- already has a Packed_Array_Impl_Type representation defined, then
4062 -- replace this attribute with a direct reference to 'Last of the
4063 -- appropriate index subtype (since otherwise the back end will try
4064 -- to give us the value of 'Last for this implementation type).
4066 if Is_Constrained_Packed_Array
(Ptyp
) then
4068 Make_Attribute_Reference
(Loc
,
4069 Attribute_Name
=> Name_Last
,
4070 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
4071 Analyze_And_Resolve
(N
, Typ
);
4073 -- For access type, apply access check as needed
4075 elsif Is_Access_Type
(Ptyp
) then
4076 Apply_Access_Check
(N
);
4078 -- For scalar type, if low bound is a reference to an entity, just
4079 -- replace with a direct reference. Note that we can only have a
4080 -- reference to a constant entity at this stage, anything else would
4081 -- have already been rewritten.
4083 elsif Is_Scalar_Type
(Ptyp
) then
4085 Hi
: constant Node_Id
:= Type_High_Bound
(Ptyp
);
4087 if Is_Entity_Name
(Hi
) then
4088 Rewrite
(N
, New_Occurrence_Of
(Entity
(Hi
), Loc
));
4097 -- We compute this if a component clause was present, otherwise we leave
4098 -- the computation up to the back end, since we don't know what layout
4101 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
4102 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4105 -- In Ada 2005 (or later) if we have the non-default bit order, then
4106 -- we return the original value as given in the component clause
4107 -- (RM 2005 13.5.2(3/2)).
4109 if Present
(Component_Clause
(CE
))
4110 and then Ada_Version
>= Ada_2005
4111 and then Reverse_Bit_Order
(Scope
(CE
))
4114 Make_Integer_Literal
(Loc
,
4115 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
4116 Analyze_And_Resolve
(N
, Typ
);
4118 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4119 -- rewrite with normalized value if we know it statically.
4121 elsif Known_Static_Component_Bit_Offset
(CE
)
4122 and then Known_Static_Esize
(CE
)
4125 Make_Integer_Literal
(Loc
,
4126 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
4128 Analyze_And_Resolve
(N
, Typ
);
4130 -- Otherwise leave to back end, just apply universal integer checks
4133 Apply_Universal_Integer_Attribute_Checks
(N
);
4141 -- Transforms 'Leading_Part into a call to the floating-point attribute
4142 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4144 -- Note: strictly, we should generate special case code to deal with
4145 -- absurdly large positive arguments (greater than Integer'Last), which
4146 -- result in returning the first argument unchanged, but it hardly seems
4147 -- worth the effort. We raise constraint error for absurdly negative
4148 -- arguments which is fine.
4150 when Attribute_Leading_Part
=>
4151 Expand_Fpt_Attribute_RI
(N
);
4157 when Attribute_Length
=> Length
: declare
4162 -- Processing for packed array types
4164 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
4165 Ityp
:= Get_Index_Subtype
(N
);
4167 -- If the index type, Ityp, is an enumeration type with holes,
4168 -- then we calculate X'Length explicitly using
4171 -- (0, Ityp'Pos (X'Last (N)) -
4172 -- Ityp'Pos (X'First (N)) + 1);
4174 -- Since the bounds in the template are the representation values
4175 -- and the back end would get the wrong value.
4177 if Is_Enumeration_Type
(Ityp
)
4178 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4183 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4187 Make_Attribute_Reference
(Loc
,
4188 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4189 Attribute_Name
=> Name_Max
,
4190 Expressions
=> New_List
4191 (Make_Integer_Literal
(Loc
, 0),
4195 Make_Op_Subtract
(Loc
,
4197 Make_Attribute_Reference
(Loc
,
4198 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4199 Attribute_Name
=> Name_Pos
,
4201 Expressions
=> New_List
(
4202 Make_Attribute_Reference
(Loc
,
4203 Prefix
=> Duplicate_Subexpr
(Pref
),
4204 Attribute_Name
=> Name_Last
,
4205 Expressions
=> New_List
(
4206 Make_Integer_Literal
(Loc
, Xnum
))))),
4209 Make_Attribute_Reference
(Loc
,
4210 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4211 Attribute_Name
=> Name_Pos
,
4213 Expressions
=> New_List
(
4214 Make_Attribute_Reference
(Loc
,
4216 Duplicate_Subexpr_No_Checks
(Pref
),
4217 Attribute_Name
=> Name_First
,
4218 Expressions
=> New_List
(
4219 Make_Integer_Literal
(Loc
, Xnum
)))))),
4221 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4223 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4226 -- If the prefix type is a constrained packed array type which
4227 -- already has a Packed_Array_Impl_Type representation defined,
4228 -- then replace this attribute with a reference to 'Range_Length
4229 -- of the appropriate index subtype (since otherwise the
4230 -- back end will try to give us the value of 'Length for
4231 -- this implementation type).s
4233 elsif Is_Constrained
(Ptyp
) then
4235 Make_Attribute_Reference
(Loc
,
4236 Attribute_Name
=> Name_Range_Length
,
4237 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4238 Analyze_And_Resolve
(N
, Typ
);
4243 elsif Is_Access_Type
(Ptyp
) then
4244 Apply_Access_Check
(N
);
4246 -- If the designated type is a packed array type, then we convert
4247 -- the reference to:
4250 -- xtyp'Pos (Pref'Last (Expr)) -
4251 -- xtyp'Pos (Pref'First (Expr)));
4253 -- This is a bit complex, but it is the easiest thing to do that
4254 -- works in all cases including enum types with holes xtyp here
4255 -- is the appropriate index type.
4258 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4262 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
4263 Xtyp
:= Get_Index_Subtype
(N
);
4266 Make_Attribute_Reference
(Loc
,
4267 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4268 Attribute_Name
=> Name_Max
,
4269 Expressions
=> New_List
(
4270 Make_Integer_Literal
(Loc
, 0),
4273 Make_Integer_Literal
(Loc
, 1),
4274 Make_Op_Subtract
(Loc
,
4276 Make_Attribute_Reference
(Loc
,
4277 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4278 Attribute_Name
=> Name_Pos
,
4279 Expressions
=> New_List
(
4280 Make_Attribute_Reference
(Loc
,
4281 Prefix
=> Duplicate_Subexpr
(Pref
),
4282 Attribute_Name
=> Name_Last
,
4284 New_Copy_List
(Exprs
)))),
4287 Make_Attribute_Reference
(Loc
,
4288 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4289 Attribute_Name
=> Name_Pos
,
4290 Expressions
=> New_List
(
4291 Make_Attribute_Reference
(Loc
,
4293 Duplicate_Subexpr_No_Checks
(Pref
),
4294 Attribute_Name
=> Name_First
,
4296 New_Copy_List
(Exprs
)))))))));
4298 Analyze_And_Resolve
(N
, Typ
);
4302 -- Otherwise leave it to the back end
4305 Apply_Universal_Integer_Attribute_Checks
(N
);
4309 -- Attribute Loop_Entry is replaced with a reference to a constant value
4310 -- which captures the prefix at the entry point of the related loop. The
4311 -- loop itself may be transformed into a conditional block.
4313 when Attribute_Loop_Entry
=>
4314 Expand_Loop_Entry_Attribute
(N
);
4320 -- Transforms 'Machine into a call to the floating-point attribute
4321 -- function Machine in Fat_xxx (where xxx is the root type).
4322 -- Expansion is avoided for cases the back end can handle directly.
4324 when Attribute_Machine
=>
4325 if not Is_Inline_Floating_Point_Attribute
(N
) then
4326 Expand_Fpt_Attribute_R
(N
);
4329 ----------------------
4330 -- Machine_Rounding --
4331 ----------------------
4333 -- Transforms 'Machine_Rounding into a call to the floating-point
4334 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4335 -- type). Expansion is avoided for cases the back end can handle
4338 when Attribute_Machine_Rounding
=>
4339 if not Is_Inline_Floating_Point_Attribute
(N
) then
4340 Expand_Fpt_Attribute_R
(N
);
4347 -- Machine_Size is equivalent to Object_Size, so transform it into
4348 -- Object_Size and that way the back end never sees Machine_Size.
4350 when Attribute_Machine_Size
=>
4352 Make_Attribute_Reference
(Loc
,
4353 Prefix
=> Prefix
(N
),
4354 Attribute_Name
=> Name_Object_Size
));
4356 Analyze_And_Resolve
(N
, Typ
);
4362 -- The only case that can get this far is the dynamic case of the old
4363 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4370 -- ityp (System.Mantissa.Mantissa_Value
4371 -- (Integer'Integer_Value (typ'First),
4372 -- Integer'Integer_Value (typ'Last)));
4374 when Attribute_Mantissa
=>
4377 Make_Function_Call
(Loc
,
4379 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4381 Parameter_Associations
=> New_List
(
4382 Make_Attribute_Reference
(Loc
,
4383 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4384 Attribute_Name
=> Name_Integer_Value
,
4385 Expressions
=> New_List
(
4386 Make_Attribute_Reference
(Loc
,
4387 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4388 Attribute_Name
=> Name_First
))),
4390 Make_Attribute_Reference
(Loc
,
4391 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4392 Attribute_Name
=> Name_Integer_Value
,
4393 Expressions
=> New_List
(
4394 Make_Attribute_Reference
(Loc
,
4395 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4396 Attribute_Name
=> Name_Last
)))))));
4398 Analyze_And_Resolve
(N
, Typ
);
4404 when Attribute_Max
=>
4405 Expand_Min_Max_Attribute
(N
);
4407 ----------------------------------
4408 -- Max_Size_In_Storage_Elements --
4409 ----------------------------------
4411 when Attribute_Max_Size_In_Storage_Elements
=> declare
4412 Typ
: constant Entity_Id
:= Etype
(N
);
4415 Conversion_Added
: Boolean := False;
4416 -- A flag which tracks whether the original attribute has been
4417 -- wrapped inside a type conversion.
4420 -- If the prefix is X'Class, we transform it into a direct reference
4421 -- to the class-wide type, because the back end must not see a 'Class
4422 -- reference. See also 'Size.
4424 if Is_Entity_Name
(Pref
)
4425 and then Is_Class_Wide_Type
(Entity
(Pref
))
4427 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4431 Apply_Universal_Integer_Attribute_Checks
(N
);
4433 -- The universal integer check may sometimes add a type conversion,
4434 -- retrieve the original attribute reference from the expression.
4438 if Nkind
(Attr
) = N_Type_Conversion
then
4439 Attr
:= Expression
(Attr
);
4440 Conversion_Added
:= True;
4443 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
4445 -- Heap-allocated controlled objects contain two extra pointers which
4446 -- are not part of the actual type. Transform the attribute reference
4447 -- into a runtime expression to add the size of the hidden header.
4449 if Needs_Finalization
(Ptyp
)
4450 and then not Header_Size_Added
(Attr
)
4452 Set_Header_Size_Added
(Attr
);
4455 -- P'Max_Size_In_Storage_Elements +
4456 -- Universal_Integer
4457 -- (Header_Size_With_Padding (Ptyp'Alignment))
4461 Left_Opnd
=> Relocate_Node
(Attr
),
4463 Convert_To
(Universal_Integer
,
4464 Make_Function_Call
(Loc
,
4467 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4469 Parameter_Associations
=> New_List
(
4470 Make_Attribute_Reference
(Loc
,
4472 New_Occurrence_Of
(Ptyp
, Loc
),
4473 Attribute_Name
=> Name_Alignment
))))));
4475 -- Add a conversion to the target type
4477 if not Conversion_Added
then
4479 Make_Type_Conversion
(Loc
,
4480 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4481 Expression
=> Relocate_Node
(Attr
)));
4489 --------------------
4490 -- Mechanism_Code --
4491 --------------------
4493 when Attribute_Mechanism_Code
=>
4495 -- We must replace the prefix in the renamed case
4497 if Is_Entity_Name
(Pref
)
4498 and then Present
(Alias
(Entity
(Pref
)))
4500 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4507 when Attribute_Min
=>
4508 Expand_Min_Max_Attribute
(N
);
4514 when Attribute_Mod
=> Mod_Case
: declare
4515 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4516 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
4517 Modv
: constant Uint
:= Modulus
(Btyp
);
4521 -- This is not so simple. The issue is what type to use for the
4522 -- computation of the modular value.
4524 -- The easy case is when the modulus value is within the bounds
4525 -- of the signed integer type of the argument. In this case we can
4526 -- just do the computation in that signed integer type, and then
4527 -- do an ordinary conversion to the target type.
4529 if Modv
<= Expr_Value
(Hi
) then
4534 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4536 -- Here we know that the modulus is larger than type'Last of the
4537 -- integer type. There are two cases to consider:
4539 -- a) The integer value is non-negative. In this case, it is
4540 -- returned as the result (since it is less than the modulus).
4542 -- b) The integer value is negative. In this case, we know that the
4543 -- result is modulus + value, where the value might be as small as
4544 -- -modulus. The trouble is what type do we use to do the subtract.
4545 -- No type will do, since modulus can be as big as 2**64, and no
4546 -- integer type accommodates this value. Let's do bit of algebra
4549 -- = modulus - (-value)
4550 -- = (modulus - 1) - (-value - 1)
4552 -- Now modulus - 1 is certainly in range of the modular type.
4553 -- -value is in the range 1 .. modulus, so -value -1 is in the
4554 -- range 0 .. modulus-1 which is in range of the modular type.
4555 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4556 -- which we can compute using the integer base type.
4558 -- Once this is done we analyze the if expression without range
4559 -- checks, because we know everything is in range, and we want
4560 -- to prevent spurious warnings on either branch.
4564 Make_If_Expression
(Loc
,
4565 Expressions
=> New_List
(
4567 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4568 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4571 Duplicate_Subexpr_No_Checks
(Arg
)),
4573 Make_Op_Subtract
(Loc
,
4575 Make_Integer_Literal
(Loc
,
4576 Intval
=> Modv
- 1),
4582 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4584 Make_Integer_Literal
(Loc
,
4585 Intval
=> 1))))))));
4589 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4596 -- Transforms 'Model into a call to the floating-point attribute
4597 -- function Model in Fat_xxx (where xxx is the root type).
4598 -- Expansion is avoided for cases the back end can handle directly.
4600 when Attribute_Model
=>
4601 if not Is_Inline_Floating_Point_Attribute
(N
) then
4602 Expand_Fpt_Attribute_R
(N
);
4609 -- The processing for Object_Size shares the processing for Size
4615 when Attribute_Old
=> Old
: declare
4616 Typ
: constant Entity_Id
:= Etype
(N
);
4617 CW_Temp
: Entity_Id
;
4624 -- Generating C code we don't need to expand this attribute when
4625 -- we are analyzing the internally built nested postconditions
4626 -- procedure since it will be expanded inline (and later it will
4627 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4628 -- performed in such case then the compiler generates unreferenced
4629 -- extra temporaries.
4631 if Modify_Tree_For_C
4632 and then Chars
(Current_Scope
) = Name_uPostconditions
4637 -- Climb the parent chain looking for subprogram _Postconditions
4640 while Present
(Subp
) loop
4641 exit when Nkind
(Subp
) = N_Subprogram_Body
4642 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4644 -- If assertions are disabled, no need to create the declaration
4645 -- that preserves the value. The postcondition pragma in which
4646 -- 'Old appears will be checked or disabled according to the
4647 -- current policy in effect.
4649 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4653 Subp
:= Parent
(Subp
);
4656 -- 'Old can only appear in a postcondition, the generated body of
4657 -- _Postconditions must be in the tree (or inlined if we are
4658 -- generating C code).
4662 or else (Modify_Tree_For_C
and then In_Inlined_Body
));
4664 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4666 -- Set the entity kind now in order to mark the temporary as a
4667 -- handler of attribute 'Old's prefix.
4669 Set_Ekind
(Temp
, E_Constant
);
4670 Set_Stores_Attribute_Old_Prefix
(Temp
);
4672 -- Push the scope of the related subprogram where _Postcondition
4673 -- resides as this ensures that the object will be analyzed in the
4676 if Present
(Subp
) then
4677 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4679 -- No need to push the scope when generating C code since the
4680 -- _Postcondition procedure has been inlined.
4682 else pragma Assert
(Modify_Tree_For_C
);
4683 pragma Assert
(In_Inlined_Body
);
4687 -- Locate the insertion place of the internal temporary that saves
4690 if Present
(Subp
) then
4693 -- Generating C, the postcondition procedure has been inlined and the
4694 -- temporary is added before the first declaration of the enclosing
4697 else pragma Assert
(Modify_Tree_For_C
);
4699 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
4700 Ins_Nod
:= Parent
(Ins_Nod
);
4703 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
4706 -- Preserve the tag of the prefix by offering a specific view of the
4707 -- class-wide version of the prefix.
4709 if Is_Tagged_Type
(Typ
) then
4712 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4714 CW_Temp
:= Make_Temporary
(Loc
, 'T');
4715 CW_Typ
:= Class_Wide_Type
(Typ
);
4717 Insert_Before_And_Analyze
(Ins_Nod
,
4718 Make_Object_Declaration
(Loc
,
4719 Defining_Identifier
=> CW_Temp
,
4720 Constant_Present
=> True,
4721 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
4723 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
4726 -- Temp : Typ renames Typ (CW_Temp);
4728 Insert_Before_And_Analyze
(Ins_Nod
,
4729 Make_Object_Renaming_Declaration
(Loc
,
4730 Defining_Identifier
=> Temp
,
4731 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4733 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
4739 -- Temp : constant Typ := Pref;
4741 Insert_Before_And_Analyze
(Ins_Nod
,
4742 Make_Object_Declaration
(Loc
,
4743 Defining_Identifier
=> Temp
,
4744 Constant_Present
=> True,
4745 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
4746 Expression
=> Relocate_Node
(Pref
)));
4749 if Present
(Subp
) then
4753 -- Ensure that the prefix of attribute 'Old is valid. The check must
4754 -- be inserted after the expansion of the attribute has taken place
4755 -- to reflect the new placement of the prefix.
4757 if Validity_Checks_On
and then Validity_Check_Operands
then
4758 Ensure_Valid
(Pref
);
4761 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4764 ----------------------
4765 -- Overlaps_Storage --
4766 ----------------------
4768 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4769 Loc
: constant Source_Ptr
:= Sloc
(N
);
4771 X
: constant Node_Id
:= Prefix
(N
);
4772 Y
: constant Node_Id
:= First
(Expressions
(N
));
4775 X_Addr
, Y_Addr
: Node_Id
;
4776 -- the expressions for their integer addresses
4778 X_Size
, Y_Size
: Node_Id
;
4779 -- the expressions for their sizes
4784 -- Attribute expands into:
4786 -- if X'Address < Y'address then
4787 -- (X'address + X'Size - 1) >= Y'address
4789 -- (Y'address + Y'size - 1) >= X'Address
4792 -- with the proper address operations. We convert addresses to
4793 -- integer addresses to use predefined arithmetic. The size is
4794 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4795 -- to prevent the appearance of the same node in two places in
4799 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4800 Make_Attribute_Reference
(Loc
,
4801 Attribute_Name
=> Name_Address
,
4802 Prefix
=> New_Copy_Tree
(X
)));
4805 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4806 Make_Attribute_Reference
(Loc
,
4807 Attribute_Name
=> Name_Address
,
4808 Prefix
=> New_Copy_Tree
(Y
)));
4811 Make_Op_Divide
(Loc
,
4813 Make_Attribute_Reference
(Loc
,
4814 Attribute_Name
=> Name_Size
,
4815 Prefix
=> New_Copy_Tree
(X
)),
4817 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4820 Make_Op_Divide
(Loc
,
4822 Make_Attribute_Reference
(Loc
,
4823 Attribute_Name
=> Name_Size
,
4824 Prefix
=> New_Copy_Tree
(Y
)),
4826 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4830 Left_Opnd
=> X_Addr
,
4831 Right_Opnd
=> Y_Addr
);
4834 Make_If_Expression
(Loc
, New_List
(
4840 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
4842 Make_Op_Subtract
(Loc
,
4843 Left_Opnd
=> X_Size
,
4844 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4845 Right_Opnd
=> Y_Addr
),
4850 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
4852 Make_Op_Subtract
(Loc
,
4853 Left_Opnd
=> Y_Size
,
4854 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4855 Right_Opnd
=> X_Addr
))));
4857 Analyze_And_Resolve
(N
, Standard_Boolean
);
4858 end Overlaps_Storage
;
4864 when Attribute_Output
=> Output
: declare
4865 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4866 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4874 -- If no underlying type, we have an error that will be diagnosed
4875 -- elsewhere, so here we just completely ignore the expansion.
4881 -- Stream operations can appear in user code even if the restriction
4882 -- No_Streams is active (for example, when instantiating a predefined
4883 -- container). In that case rewrite the attribute as a Raise to
4884 -- prevent any run-time use.
4886 if Restriction_Active
(No_Streams
) then
4888 Make_Raise_Program_Error
(Sloc
(N
),
4889 Reason
=> PE_Stream_Operation_Not_Allowed
));
4890 Set_Etype
(N
, Standard_Void_Type
);
4894 -- If TSS for Output is present, just call it
4896 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
4898 if Present
(Pname
) then
4902 -- If there is a Stream_Convert pragma, use it, we rewrite
4904 -- sourcetyp'Output (stream, Item)
4908 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4910 -- where strmwrite is the given Write function that converts an
4911 -- argument of type sourcetyp or a type acctyp, from which it is
4912 -- derived to type strmtyp. The conversion to acttyp is required
4913 -- for the derived case.
4915 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4917 if Present
(Prag
) then
4919 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4920 Wfunc
:= Entity
(Expression
(Arg3
));
4923 Make_Attribute_Reference
(Loc
,
4924 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4925 Attribute_Name
=> Name_Output
,
4926 Expressions
=> New_List
(
4927 Relocate_Node
(First
(Exprs
)),
4928 Make_Function_Call
(Loc
,
4929 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4930 Parameter_Associations
=> New_List
(
4931 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4932 Relocate_Node
(Next
(First
(Exprs
)))))))));
4937 -- For elementary types, we call the W_xxx routine directly. Note
4938 -- that the effect of Write and Output is identical for the case
4939 -- of an elementary type (there are no discriminants or bounds).
4941 elsif Is_Elementary_Type
(U_Type
) then
4943 -- A special case arises if we have a defined _Write routine,
4944 -- since in this case we are required to call this routine.
4947 Typ
: Entity_Id
:= P_Type
;
4949 if Present
(Full_View
(Typ
)) then
4950 Typ
:= Full_View
(Typ
);
4953 if Present
(TSS
(Base_Type
(Typ
), TSS_Stream_Write
)) then
4954 Build_Record_Or_Elementary_Output_Procedure
4955 (Loc
, Typ
, Decl
, Pname
);
4956 Insert_Action
(N
, Decl
);
4958 -- For normal cases, we call the W_xxx routine directly
4961 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4969 elsif Is_Array_Type
(U_Type
) then
4970 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4971 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4973 -- Class-wide case, first output external tag, then dispatch
4974 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4976 elsif Is_Class_Wide_Type
(P_Type
) then
4978 -- No need to do anything else compiling under restriction
4979 -- No_Dispatching_Calls. During the semantic analysis we
4980 -- already notified such violation.
4982 if Restriction_Active
(No_Dispatching_Calls
) then
4987 Strm
: constant Node_Id
:= First
(Exprs
);
4988 Item
: constant Node_Id
:= Next
(Strm
);
4991 -- Ada 2005 (AI-344): Check that the accessibility level
4992 -- of the type of the output object is not deeper than
4993 -- that of the attribute's prefix type.
4995 -- if Get_Access_Level (Item'Tag)
4996 -- /= Get_Access_Level (P_Type'Tag)
5001 -- String'Output (Strm, External_Tag (Item'Tag));
5003 -- We cannot figure out a practical way to implement this
5004 -- accessibility check on virtual machines, so we omit it.
5006 if Ada_Version
>= Ada_2005
5007 and then Tagged_Type_Expansion
5010 Make_Implicit_If_Statement
(N
,
5014 Build_Get_Access_Level
(Loc
,
5015 Make_Attribute_Reference
(Loc
,
5018 Duplicate_Subexpr
(Item
,
5020 Attribute_Name
=> Name_Tag
)),
5023 Make_Integer_Literal
(Loc
,
5024 Type_Access_Level
(P_Type
))),
5027 New_List
(Make_Raise_Statement
(Loc
,
5029 RTE
(RE_Tag_Error
), Loc
)))));
5033 Make_Attribute_Reference
(Loc
,
5034 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
5035 Attribute_Name
=> Name_Output
,
5036 Expressions
=> New_List
(
5037 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
5038 Make_Function_Call
(Loc
,
5040 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
5041 Parameter_Associations
=> New_List
(
5042 Make_Attribute_Reference
(Loc
,
5045 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
5046 Attribute_Name
=> Name_Tag
))))));
5049 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5051 -- Tagged type case, use the primitive Output function
5053 elsif Is_Tagged_Type
(U_Type
) then
5054 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5056 -- All other record type cases, including protected records.
5057 -- The latter only arise for expander generated code for
5058 -- handling shared passive partition access.
5062 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5064 -- Ada 2005 (AI-216): Program_Error is raised when executing
5065 -- the default implementation of the Output attribute of an
5066 -- unchecked union type if the type lacks default discriminant
5069 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5070 and then No
(Discriminant_Constraint
(U_Type
))
5073 Make_Raise_Program_Error
(Loc
,
5074 Reason
=> PE_Unchecked_Union_Restriction
));
5079 Build_Record_Or_Elementary_Output_Procedure
5080 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
5081 Insert_Action
(N
, Decl
);
5085 -- If we fall through, Pname is the name of the procedure to call
5087 Rewrite_Stream_Proc_Call
(Pname
);
5094 -- For enumeration types with a standard representation, Pos is
5095 -- handled by the back end.
5097 -- For enumeration types, with a non-standard representation we generate
5098 -- a call to the _Rep_To_Pos function created when the type was frozen.
5099 -- The call has the form
5101 -- _rep_to_pos (expr, flag)
5103 -- The parameter flag is True if range checks are enabled, causing
5104 -- Program_Error to be raised if the expression has an invalid
5105 -- representation, and False if range checks are suppressed.
5107 -- For integer types, Pos is equivalent to a simple integer
5108 -- conversion and we rewrite it as such
5110 when Attribute_Pos
=> Pos
: declare
5111 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
5114 -- Deal with zero/non-zero boolean values
5116 if Is_Boolean_Type
(Etyp
) then
5117 Adjust_Condition
(First
(Exprs
));
5118 Etyp
:= Standard_Boolean
;
5119 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5122 -- Case of enumeration type
5124 if Is_Enumeration_Type
(Etyp
) then
5126 -- Non-standard enumeration type (generate call)
5128 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5129 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5132 Make_Function_Call
(Loc
,
5134 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5135 Parameter_Associations
=> Exprs
)));
5137 Analyze_And_Resolve
(N
, Typ
);
5139 -- Standard enumeration type (do universal integer check)
5142 Apply_Universal_Integer_Attribute_Checks
(N
);
5145 -- Deal with integer types (replace by conversion)
5147 elsif Is_Integer_Type
(Etyp
) then
5148 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
5149 Analyze_And_Resolve
(N
, Typ
);
5158 -- We compute this if a component clause was present, otherwise we leave
5159 -- the computation up to the back end, since we don't know what layout
5162 when Attribute_Position
=> Position_Attr
: declare
5163 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5166 if Present
(Component_Clause
(CE
)) then
5168 -- In Ada 2005 (or later) if we have the non-default bit order,
5169 -- then we return the original value as given in the component
5170 -- clause (RM 2005 13.5.2(2/2)).
5172 if Ada_Version
>= Ada_2005
5173 and then Reverse_Bit_Order
(Scope
(CE
))
5176 Make_Integer_Literal
(Loc
,
5177 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
5179 -- Otherwise (Ada 83 or 95, or default bit order specified in
5180 -- later Ada version), return the normalized value.
5184 Make_Integer_Literal
(Loc
,
5185 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
5188 Analyze_And_Resolve
(N
, Typ
);
5190 -- If back end is doing things, just apply universal integer checks
5193 Apply_Universal_Integer_Attribute_Checks
(N
);
5201 -- 1. Deal with enumeration types with holes.
5202 -- 2. For floating-point, generate call to attribute function.
5203 -- 3. For other cases, deal with constraint checking.
5205 when Attribute_Pred
=> Pred
: declare
5206 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5210 -- For enumeration types with non-standard representations, we
5211 -- expand typ'Pred (x) into
5213 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5215 -- If the representation is contiguous, we compute instead
5216 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5217 -- The conversion function Enum_Pos_To_Rep is defined on the
5218 -- base type, not the subtype, so we have to use the base type
5219 -- explicitly for this and other enumeration attributes.
5221 if Is_Enumeration_Type
(Ptyp
)
5222 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5224 if Has_Contiguous_Rep
(Etyp
) then
5226 Unchecked_Convert_To
(Ptyp
,
5229 Make_Integer_Literal
(Loc
,
5230 Enumeration_Rep
(First_Literal
(Ptyp
))),
5232 Make_Function_Call
(Loc
,
5235 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5237 Parameter_Associations
=>
5239 Unchecked_Convert_To
(Ptyp
,
5240 Make_Op_Subtract
(Loc
,
5242 Unchecked_Convert_To
(Standard_Integer
,
5243 Relocate_Node
(First
(Exprs
))),
5245 Make_Integer_Literal
(Loc
, 1))),
5246 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5249 -- Add Boolean parameter True, to request program errror if
5250 -- we have a bad representation on our hands. If checks are
5251 -- suppressed, then add False instead
5253 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5255 Make_Indexed_Component
(Loc
,
5258 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5259 Expressions
=> New_List
(
5260 Make_Op_Subtract
(Loc
,
5262 Make_Function_Call
(Loc
,
5265 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5266 Parameter_Associations
=> Exprs
),
5267 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5270 Analyze_And_Resolve
(N
, Typ
);
5272 -- For floating-point, we transform 'Pred into a call to the Pred
5273 -- floating-point attribute function in Fat_xxx (xxx is root type).
5274 -- Note that this function takes care of the overflow case.
5276 elsif Is_Floating_Point_Type
(Ptyp
) then
5277 Expand_Fpt_Attribute_R
(N
);
5278 Analyze_And_Resolve
(N
, Typ
);
5280 -- For modular types, nothing to do (no overflow, since wraps)
5282 elsif Is_Modular_Integer_Type
(Ptyp
) then
5285 -- For other types, if argument is marked as needing a range check or
5286 -- overflow checking is enabled, we must generate a check.
5288 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5289 or else Do_Range_Check
(First
(Exprs
))
5291 Set_Do_Range_Check
(First
(Exprs
), False);
5292 Expand_Pred_Succ_Attribute
(N
);
5300 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5302 -- We rewrite X'Priority as the following run-time call:
5304 -- Get_Ceiling (X._Object)
5306 -- Note that although X'Priority is notionally an object, it is quite
5307 -- deliberately not defined as an aliased object in the RM. This means
5308 -- that it works fine to rewrite it as a call, without having to worry
5309 -- about complications that would other arise from X'Priority'Access,
5310 -- which is illegal, because of the lack of aliasing.
5312 when Attribute_Priority
=> Priority
: declare
5314 Conctyp
: Entity_Id
;
5315 New_Itype
: Entity_Id
;
5316 Object_Parm
: Node_Id
;
5318 RT_Subprg_Name
: Node_Id
;
5321 -- Look for the enclosing concurrent type
5323 Conctyp
:= Current_Scope
;
5324 while not Is_Concurrent_Type
(Conctyp
) loop
5325 Conctyp
:= Scope
(Conctyp
);
5328 pragma Assert
(Is_Protected_Type
(Conctyp
));
5330 -- Generate the actual of the call
5332 Subprg
:= Current_Scope
;
5333 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5334 Subprg
:= Scope
(Subprg
);
5337 -- Use of 'Priority inside protected entries and barriers (in both
5338 -- cases the type of the first formal of their expanded subprogram
5341 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5344 -- In the expansion of protected entries the type of the first
5345 -- formal of the Protected_Body_Subprogram is an Address. In order
5346 -- to reference the _object component we generate:
5348 -- type T is access p__ptTV;
5351 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5352 Set_Etype
(New_Itype
, New_Itype
);
5353 Set_Directly_Designated_Type
(New_Itype
,
5354 Corresponding_Record_Type
(Conctyp
));
5355 Freeze_Itype
(New_Itype
, N
);
5358 -- T!(O)._object'unchecked_access
5361 Make_Attribute_Reference
(Loc
,
5363 Make_Selected_Component
(Loc
,
5365 Unchecked_Convert_To
(New_Itype
,
5367 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5369 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5370 Attribute_Name
=> Name_Unchecked_Access
);
5372 -- Use of 'Priority inside a protected subprogram
5376 Make_Attribute_Reference
(Loc
,
5378 Make_Selected_Component
(Loc
,
5381 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5383 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5384 Attribute_Name
=> Name_Unchecked_Access
);
5387 -- Select the appropriate run-time subprogram
5389 if Number_Entries
(Conctyp
) = 0 then
5390 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5392 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5396 Make_Function_Call
(Loc
,
5397 Name
=> RT_Subprg_Name
,
5398 Parameter_Associations
=> New_List
(Object_Parm
));
5402 -- Avoid the generation of extra checks on the pointer to the
5403 -- protected object.
5405 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5412 when Attribute_Range_Length
=>
5414 -- The only special processing required is for the case where
5415 -- Range_Length is applied to an enumeration type with holes.
5416 -- In this case we transform
5422 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5424 -- So that the result reflects the proper Pos values instead
5425 -- of the underlying representations.
5427 if Is_Enumeration_Type
(Ptyp
)
5428 and then Has_Non_Standard_Rep
(Ptyp
)
5433 Make_Op_Subtract
(Loc
,
5435 Make_Attribute_Reference
(Loc
,
5436 Attribute_Name
=> Name_Pos
,
5437 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5438 Expressions
=> New_List
(
5439 Make_Attribute_Reference
(Loc
,
5440 Attribute_Name
=> Name_Last
,
5442 New_Occurrence_Of
(Ptyp
, Loc
)))),
5445 Make_Attribute_Reference
(Loc
,
5446 Attribute_Name
=> Name_Pos
,
5447 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5448 Expressions
=> New_List
(
5449 Make_Attribute_Reference
(Loc
,
5450 Attribute_Name
=> Name_First
,
5452 New_Occurrence_Of
(Ptyp
, Loc
))))),
5454 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5456 Analyze_And_Resolve
(N
, Typ
);
5458 -- For all other cases, the attribute is handled by the back end, but
5459 -- we need to deal with the case of the range check on a universal
5463 Apply_Universal_Integer_Attribute_Checks
(N
);
5470 when Attribute_Reduce
=>
5472 Loc
: constant Source_Ptr
:= Sloc
(N
);
5473 E1
: constant Node_Id
:= First
(Expressions
(N
));
5474 E2
: constant Node_Id
:= Next
(E1
);
5475 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
5476 Typ
: constant Entity_Id
:= Etype
(N
);
5479 -- If the prefix is an aggregwte, its unique component is sn
5480 -- Iterated_Element, and we create a loop out of its itertor.
5483 if Nkind
(Prefix
(N
)) = N_Aggregate
then
5485 Stream
: constant Node_Id
:=
5486 First
(Component_Associations
(Prefix
(N
)));
5487 Id
: constant Node_Id
:= Defining_Identifier
(Stream
);
5488 Expr
: constant Node_Id
:= Expression
(Stream
);
5489 Ch
: constant Node_Id
:=
5490 First
(Discrete_Choices
(Stream
));
5492 New_Loop
:= Make_Loop_Statement
(Loc
,
5494 Make_Iteration_Scheme
(Loc
,
5495 Iterator_Specification
=> Empty
,
5496 Loop_Parameter_Specification
=>
5497 Make_Loop_Parameter_Specification
(Loc
,
5498 Defining_Identifier
=> New_Copy
(Id
),
5499 Discrete_Subtype_Definition
=>
5500 Relocate_Node
(Ch
))),
5502 Statements
=> New_List
(
5503 Make_Assignment_Statement
(Loc
,
5504 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
5505 Expression
=> Make_Function_Call
(Loc
,
5506 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
5507 Parameter_Associations
=> New_List
(
5508 New_Occurrence_Of
(Bnn
, Loc
),
5509 Relocate_Node
(Expr
))))));
5512 -- If the prefix is a name we construct an element iterwtor
5513 -- over it. Its expansion will verify that it is an array
5514 -- or a container with the proper aspects.
5518 Elem
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
5522 Make_Iterator_Specification
(Loc
,
5523 Defining_Identifier
=> Elem
,
5524 Name
=> Relocate_Node
(Prefix
(N
)),
5525 Subtype_Indication
=> Empty
);
5526 Set_Of_Present
(Iter
);
5528 New_Loop
:= Make_Loop_Statement
(Loc
,
5530 Make_Iteration_Scheme
(Loc
,
5531 Iterator_Specification
=> Iter
,
5532 Loop_Parameter_Specification
=> Empty
),
5534 Statements
=> New_List
(
5535 Make_Assignment_Statement
(Loc
,
5536 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
5537 Expression
=> Make_Function_Call
(Loc
,
5538 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
5539 Parameter_Associations
=> New_List
(
5540 New_Occurrence_Of
(Bnn
, Loc
),
5541 New_Occurrence_Of
(Elem
, Loc
))))));
5546 Make_Expression_With_Actions
(Loc
,
5547 Actions
=> New_List
(
5548 Make_Object_Declaration
(Loc
,
5549 Defining_Identifier
=> Bnn
,
5550 Object_Definition
=>
5551 New_Occurrence_Of
(Typ
, Loc
),
5552 Expression
=> Relocate_Node
(E2
)), New_Loop
),
5553 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
5554 Analyze_And_Resolve
(N
, Typ
);
5561 when Attribute_Read
=> Read
: declare
5562 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5563 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
5564 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5574 -- If no underlying type, we have an error that will be diagnosed
5575 -- elsewhere, so here we just completely ignore the expansion.
5581 -- Stream operations can appear in user code even if the restriction
5582 -- No_Streams is active (for example, when instantiating a predefined
5583 -- container). In that case rewrite the attribute as a Raise to
5584 -- prevent any run-time use.
5586 if Restriction_Active
(No_Streams
) then
5588 Make_Raise_Program_Error
(Sloc
(N
),
5589 Reason
=> PE_Stream_Operation_Not_Allowed
));
5590 Set_Etype
(N
, B_Type
);
5594 -- The simple case, if there is a TSS for Read, just call it
5596 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
5598 if Present
(Pname
) then
5602 -- If there is a Stream_Convert pragma, use it, we rewrite
5604 -- sourcetyp'Read (stream, Item)
5608 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5610 -- where strmread is the given Read function that converts an
5611 -- argument of type strmtyp to type sourcetyp or a type from which
5612 -- it is derived. The conversion to sourcetyp is required in the
5615 -- A special case arises if Item is a type conversion in which
5616 -- case, we have to expand to:
5618 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5620 -- where Itemx is the expression of the type conversion (i.e.
5621 -- the actual object), and typex is the type of Itemx.
5623 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5625 if Present
(Prag
) then
5626 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
5627 Rfunc
:= Entity
(Expression
(Arg2
));
5628 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5630 OK_Convert_To
(B_Type
,
5631 Make_Function_Call
(Loc
,
5632 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
5633 Parameter_Associations
=> New_List
(
5634 Make_Attribute_Reference
(Loc
,
5637 (Etype
(First_Formal
(Rfunc
)), Loc
),
5638 Attribute_Name
=> Name_Input
,
5639 Expressions
=> New_List
(
5640 Relocate_Node
(First
(Exprs
)))))));
5642 if Nkind
(Lhs
) = N_Type_Conversion
then
5643 Lhs
:= Expression
(Lhs
);
5644 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5648 Make_Assignment_Statement
(Loc
,
5650 Expression
=> Rhs
));
5651 Set_Assignment_OK
(Lhs
);
5655 -- For elementary types, we call the I_xxx routine using the first
5656 -- parameter and then assign the result into the second parameter.
5657 -- We set Assignment_OK to deal with the conversion case.
5659 elsif Is_Elementary_Type
(U_Type
) then
5665 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5666 Rhs
:= Build_Elementary_Input_Call
(N
);
5668 if Nkind
(Lhs
) = N_Type_Conversion
then
5669 Lhs
:= Expression
(Lhs
);
5670 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5673 Set_Assignment_OK
(Lhs
);
5676 Make_Assignment_Statement
(Loc
,
5678 Expression
=> Rhs
));
5686 elsif Is_Array_Type
(U_Type
) then
5687 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
5688 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5690 -- Tagged type case, use the primitive Read function. Note that
5691 -- this will dispatch in the class-wide case which is what we want
5693 elsif Is_Tagged_Type
(U_Type
) then
5694 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
5696 -- All other record type cases, including protected records. The
5697 -- latter only arise for expander generated code for handling
5698 -- shared passive partition access.
5702 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5704 -- Ada 2005 (AI-216): Program_Error is raised when executing
5705 -- the default implementation of the Read attribute of an
5706 -- Unchecked_Union type. We replace the attribute with a
5707 -- raise statement (rather than inserting it before) to handle
5708 -- properly the case of an unchecked union that is a record
5711 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
5713 Make_Raise_Program_Error
(Loc
,
5714 Reason
=> PE_Unchecked_Union_Restriction
));
5715 Set_Etype
(N
, B_Type
);
5719 if Has_Discriminants
(U_Type
)
5721 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5723 Build_Mutable_Record_Read_Procedure
5724 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5726 Build_Record_Read_Procedure
5727 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5730 -- Suppress checks, uninitialized or otherwise invalid
5731 -- data does not cause constraint errors to be raised for
5732 -- a complete record read.
5734 Insert_Action
(N
, Decl
, All_Checks
);
5738 Rewrite_Stream_Proc_Call
(Pname
);
5745 -- Ref is identical to To_Address, see To_Address for processing
5751 -- Transforms 'Remainder into a call to the floating-point attribute
5752 -- function Remainder in Fat_xxx (where xxx is the root type)
5754 when Attribute_Remainder
=>
5755 Expand_Fpt_Attribute_RR
(N
);
5761 -- Transform 'Result into reference to _Result formal. At the point
5762 -- where a legal 'Result attribute is expanded, we know that we are in
5763 -- the context of a _Postcondition function with a _Result parameter.
5765 when Attribute_Result
=>
5766 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
5767 Analyze_And_Resolve
(N
, Typ
);
5773 -- The handling of the Round attribute is quite delicate. The processing
5774 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5775 -- semantics of Round, but we do not want anything to do with universal
5776 -- real at runtime, since this corresponds to using floating-point
5779 -- What we have now is that the Etype of the Round attribute correctly
5780 -- indicates the final result type. The operand of the Round is the
5781 -- conversion to universal real, described above, and the operand of
5782 -- this conversion is the actual operand of Round, which may be the
5783 -- special case of a fixed point multiplication or division (Etype =
5786 -- The exapander will expand first the operand of the conversion, then
5787 -- the conversion, and finally the round attribute itself, since we
5788 -- always work inside out. But we cannot simply process naively in this
5789 -- order. In the semantic world where universal fixed and real really
5790 -- exist and have infinite precision, there is no problem, but in the
5791 -- implementation world, where universal real is a floating-point type,
5792 -- we would get the wrong result.
5794 -- So the approach is as follows. First, when expanding a multiply or
5795 -- divide whose type is universal fixed, we do nothing at all, instead
5796 -- deferring the operation till later.
5798 -- The actual processing is done in Expand_N_Type_Conversion which
5799 -- handles the special case of Round by looking at its parent to see if
5800 -- it is a Round attribute, and if it is, handling the conversion (or
5801 -- its fixed multiply/divide child) in an appropriate manner.
5803 -- This means that by the time we get to expanding the Round attribute
5804 -- itself, the Round is nothing more than a type conversion (and will
5805 -- often be a null type conversion), so we just replace it with the
5806 -- appropriate conversion operation.
5808 when Attribute_Round
=>
5810 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
5811 Analyze_And_Resolve
(N
);
5817 -- Transforms 'Rounding into a call to the floating-point attribute
5818 -- function Rounding in Fat_xxx (where xxx is the root type)
5819 -- Expansion is avoided for cases the back end can handle directly.
5821 when Attribute_Rounding
=>
5822 if not Is_Inline_Floating_Point_Attribute
(N
) then
5823 Expand_Fpt_Attribute_R
(N
);
5830 -- Transforms 'Scaling into a call to the floating-point attribute
5831 -- function Scaling in Fat_xxx (where xxx is the root type)
5833 when Attribute_Scaling
=>
5834 Expand_Fpt_Attribute_RI
(N
);
5836 -------------------------
5837 -- Simple_Storage_Pool --
5838 -------------------------
5840 when Attribute_Simple_Storage_Pool
=>
5842 Make_Type_Conversion
(Loc
,
5843 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5844 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5845 Analyze_And_Resolve
(N
, Typ
);
5851 when Attribute_Object_Size
5853 | Attribute_Value_Size
5854 | Attribute_VADS_Size
5860 -- Processing for VADS_Size case. Note that this processing
5861 -- removes all traces of VADS_Size from the tree, and completes
5862 -- all required processing for VADS_Size by translating the
5863 -- attribute reference to an appropriate Size or Object_Size
5866 if Id
= Attribute_VADS_Size
5867 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5869 -- If the size is specified, then we simply use the specified
5870 -- size. This applies to both types and objects. The size of an
5871 -- object can be specified in the following ways:
5873 -- An explicit size object is given for an object
5874 -- A component size is specified for an indexed component
5875 -- A component clause is specified for a selected component
5876 -- The object is a component of a packed composite object
5878 -- If the size is specified, then VADS_Size of an object
5880 if (Is_Entity_Name
(Pref
)
5881 and then Present
(Size_Clause
(Entity
(Pref
))))
5883 (Nkind
(Pref
) = N_Component_Clause
5884 and then (Present
(Component_Clause
5885 (Entity
(Selector_Name
(Pref
))))
5886 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5888 (Nkind
(Pref
) = N_Indexed_Component
5889 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5890 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5892 Set_Attribute_Name
(N
, Name_Size
);
5894 -- Otherwise if we have an object rather than a type, then
5895 -- the VADS_Size attribute applies to the type of the object,
5896 -- rather than the object itself. This is one of the respects
5897 -- in which VADS_Size differs from Size.
5900 if (not Is_Entity_Name
(Pref
)
5901 or else not Is_Type
(Entity
(Pref
)))
5902 and then (Is_Scalar_Type
(Ptyp
)
5903 or else Is_Constrained
(Ptyp
))
5905 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
5908 -- For a scalar type for which no size was explicitly given,
5909 -- VADS_Size means Object_Size. This is the other respect in
5910 -- which VADS_Size differs from Size.
5912 if Is_Scalar_Type
(Ptyp
)
5913 and then No
(Size_Clause
(Ptyp
))
5915 Set_Attribute_Name
(N
, Name_Object_Size
);
5917 -- In all other cases, Size and VADS_Size are the sane
5920 Set_Attribute_Name
(N
, Name_Size
);
5925 -- If the prefix is X'Class, transform it into a direct reference
5926 -- to the class-wide type, because the back end must not see a
5927 -- 'Class reference.
5929 if Is_Entity_Name
(Pref
)
5930 and then Is_Class_Wide_Type
(Entity
(Pref
))
5932 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
5935 -- For X'Size applied to an object of a class-wide type, transform
5936 -- X'Size into a call to the primitive operation _Size applied to
5939 elsif Is_Class_Wide_Type
(Ptyp
) then
5941 -- No need to do anything else compiling under restriction
5942 -- No_Dispatching_Calls. During the semantic analysis we
5943 -- already noted this restriction violation.
5945 if Restriction_Active
(No_Dispatching_Calls
) then
5950 Make_Function_Call
(Loc
,
5952 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
5953 Parameter_Associations
=> New_List
(Pref
));
5955 if Typ
/= Standard_Long_Long_Integer
then
5957 -- The context is a specific integer type with which the
5958 -- original attribute was compatible. The function has a
5959 -- specific type as well, so to preserve the compatibility
5960 -- we must convert explicitly.
5962 New_Node
:= Convert_To
(Typ
, New_Node
);
5965 Rewrite
(N
, New_Node
);
5966 Analyze_And_Resolve
(N
, Typ
);
5970 -- Call Expand_Size_Attribute to do the final part of the
5971 -- expansion which is shared with GNATprove expansion.
5973 Expand_Size_Attribute
(N
);
5980 when Attribute_Storage_Pool
=>
5982 Make_Type_Conversion
(Loc
,
5983 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5984 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5985 Analyze_And_Resolve
(N
, Typ
);
5991 when Attribute_Storage_Size
=> Storage_Size
: declare
5992 Alloc_Op
: Entity_Id
:= Empty
;
5996 -- Access type case, always go to the root type
5998 -- The case of access types results in a value of zero for the case
5999 -- where no storage size attribute clause has been given. If a
6000 -- storage size has been given, then the attribute is converted
6001 -- to a reference to the variable used to hold this value.
6003 if Is_Access_Type
(Ptyp
) then
6004 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
6006 Make_Attribute_Reference
(Loc
,
6007 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
6008 Attribute_Name
=> Name_Max
,
6009 Expressions
=> New_List
(
6010 Make_Integer_Literal
(Loc
, 0),
6013 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
6015 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
6017 -- If the access type is associated with a simple storage pool
6018 -- object, then attempt to locate the optional Storage_Size
6019 -- function of the simple storage pool type. If not found,
6020 -- then the result will default to zero.
6022 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
6023 Name_Simple_Storage_Pool_Type
))
6026 Pool_Type
: constant Entity_Id
:=
6027 Base_Type
(Etype
(Entity
(N
)));
6030 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
6031 while Present
(Alloc_Op
) loop
6032 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
6033 and then Present
(First_Formal
(Alloc_Op
))
6034 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
6039 Alloc_Op
:= Homonym
(Alloc_Op
);
6043 -- In the normal Storage_Pool case, retrieve the primitive
6044 -- function associated with the pool type.
6049 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
6050 Attribute_Name
(N
));
6053 -- If Storage_Size wasn't found (can only occur in the simple
6054 -- storage pool case), then simply use zero for the result.
6056 if not Present
(Alloc_Op
) then
6057 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6059 -- Otherwise, rewrite the allocator as a call to pool type's
6060 -- Storage_Size function.
6065 Make_Function_Call
(Loc
,
6067 New_Occurrence_Of
(Alloc_Op
, Loc
),
6069 Parameter_Associations
=> New_List
(
6071 (Associated_Storage_Pool
6072 (Root_Type
(Ptyp
)), Loc
)))));
6076 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6079 Analyze_And_Resolve
(N
, Typ
);
6081 -- For tasks, we retrieve the size directly from the TCB. The
6082 -- size may depend on a discriminant of the type, and therefore
6083 -- can be a per-object expression, so type-level information is
6084 -- not sufficient in general. There are four cases to consider:
6086 -- a) If the attribute appears within a task body, the designated
6087 -- TCB is obtained by a call to Self.
6089 -- b) If the prefix of the attribute is the name of a task object,
6090 -- the designated TCB is the one stored in the corresponding record.
6092 -- c) If the prefix is a task type, the size is obtained from the
6093 -- size variable created for each task type
6095 -- d) If no Storage_Size was specified for the type, there is no
6096 -- size variable, and the value is a system-specific default.
6099 if In_Open_Scopes
(Ptyp
) then
6101 -- Storage_Size (Self)
6105 Make_Function_Call
(Loc
,
6107 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6108 Parameter_Associations
=>
6110 Make_Function_Call
(Loc
,
6112 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6114 elsif not Is_Entity_Name
(Pref
)
6115 or else not Is_Type
(Entity
(Pref
))
6117 -- Storage_Size (Rec (Obj).Size)
6121 Make_Function_Call
(Loc
,
6123 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6124 Parameter_Associations
=>
6126 Make_Selected_Component
(Loc
,
6128 Unchecked_Convert_To
(
6129 Corresponding_Record_Type
(Ptyp
),
6130 New_Copy_Tree
(Pref
)),
6132 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6134 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6136 -- Static Storage_Size pragma given for type: retrieve value
6137 -- from its allocated storage variable.
6141 Make_Function_Call
(Loc
,
6142 Name
=> New_Occurrence_Of
(
6143 RTE
(RE_Adjust_Storage_Size
), Loc
),
6144 Parameter_Associations
=>
6147 Storage_Size_Variable
(Ptyp
), Loc
)))));
6149 -- Get system default
6153 Make_Function_Call
(Loc
,
6156 RTE
(RE_Default_Stack_Size
), Loc
))));
6159 Analyze_And_Resolve
(N
, Typ
);
6167 when Attribute_Stream_Size
=>
6169 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6170 Analyze_And_Resolve
(N
, Typ
);
6176 -- 1. Deal with enumeration types with holes.
6177 -- 2. For floating-point, generate call to attribute function.
6178 -- 3. For other cases, deal with constraint checking.
6180 when Attribute_Succ
=> Succ
: declare
6181 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6184 -- For enumeration types with non-standard representations, we
6185 -- expand typ'Succ (x) into
6187 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6189 -- If the representation is contiguous, we compute instead
6190 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6192 if Is_Enumeration_Type
(Ptyp
)
6193 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6195 if Has_Contiguous_Rep
(Etyp
) then
6197 Unchecked_Convert_To
(Ptyp
,
6200 Make_Integer_Literal
(Loc
,
6201 Enumeration_Rep
(First_Literal
(Ptyp
))),
6203 Make_Function_Call
(Loc
,
6206 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6208 Parameter_Associations
=>
6210 Unchecked_Convert_To
(Ptyp
,
6213 Unchecked_Convert_To
(Standard_Integer
,
6214 Relocate_Node
(First
(Exprs
))),
6216 Make_Integer_Literal
(Loc
, 1))),
6217 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
6219 -- Add Boolean parameter True, to request program errror if
6220 -- we have a bad representation on our hands. Add False if
6221 -- checks are suppressed.
6223 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6225 Make_Indexed_Component
(Loc
,
6228 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6229 Expressions
=> New_List
(
6232 Make_Function_Call
(Loc
,
6235 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6236 Parameter_Associations
=> Exprs
),
6237 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6240 Analyze_And_Resolve
(N
, Typ
);
6242 -- For floating-point, we transform 'Succ into a call to the Succ
6243 -- floating-point attribute function in Fat_xxx (xxx is root type)
6245 elsif Is_Floating_Point_Type
(Ptyp
) then
6246 Expand_Fpt_Attribute_R
(N
);
6247 Analyze_And_Resolve
(N
, Typ
);
6249 -- For modular types, nothing to do (no overflow, since wraps)
6251 elsif Is_Modular_Integer_Type
(Ptyp
) then
6254 -- For other types, if argument is marked as needing a range check or
6255 -- overflow checking is enabled, we must generate a check.
6257 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6258 or else Do_Range_Check
(First
(Exprs
))
6260 Set_Do_Range_Check
(First
(Exprs
), False);
6261 Expand_Pred_Succ_Attribute
(N
);
6269 -- Transforms X'Tag into a direct reference to the tag of X
6271 when Attribute_Tag
=> Tag
: declare
6273 Prefix_Is_Type
: Boolean;
6276 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6277 Ttyp
:= Entity
(Pref
);
6278 Prefix_Is_Type
:= True;
6281 Prefix_Is_Type
:= False;
6284 if Is_Class_Wide_Type
(Ttyp
) then
6285 Ttyp
:= Root_Type
(Ttyp
);
6288 Ttyp
:= Underlying_Type
(Ttyp
);
6290 -- Ada 2005: The type may be a synchronized tagged type, in which
6291 -- case the tag information is stored in the corresponding record.
6293 if Is_Concurrent_Type
(Ttyp
) then
6294 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6297 if Prefix_Is_Type
then
6299 -- For VMs we leave the type attribute unexpanded because
6300 -- there's not a dispatching table to reference.
6302 if Tagged_Type_Expansion
then
6304 Unchecked_Convert_To
(RTE
(RE_Tag
),
6306 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6307 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6310 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6311 -- references the primary tag of the actual object. If 'Tag is
6312 -- applied to class-wide interface objects we generate code that
6313 -- displaces "this" to reference the base of the object.
6315 elsif Comes_From_Source
(N
)
6316 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6317 and then Is_Interface
(Underlying_Type
(Etype
(Prefix
(N
))))
6320 -- (To_Tag_Ptr (Prefix'Address)).all
6322 -- Note that Prefix'Address is recursively expanded into a call
6323 -- to Base_Address (Obj.Tag)
6325 -- Not needed for VM targets, since all handled by the VM
6327 if Tagged_Type_Expansion
then
6329 Make_Explicit_Dereference
(Loc
,
6330 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6331 Make_Attribute_Reference
(Loc
,
6332 Prefix
=> Relocate_Node
(Pref
),
6333 Attribute_Name
=> Name_Address
))));
6334 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6339 Make_Selected_Component
(Loc
,
6340 Prefix
=> Relocate_Node
(Pref
),
6342 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6343 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6351 -- Transforms 'Terminated attribute into a call to Terminated function
6353 when Attribute_Terminated
=> Terminated
: begin
6355 -- The prefix of Terminated is of a task interface class-wide type.
6357 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6359 if Ada_Version
>= Ada_2005
6360 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6361 and then Is_Interface
(Ptyp
)
6362 and then Is_Task_Interface
(Ptyp
)
6365 Make_Function_Call
(Loc
,
6367 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6368 Parameter_Associations
=> New_List
(
6369 Make_Unchecked_Type_Conversion
(Loc
,
6371 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6372 Expression
=> Build_Disp_Get_Task_Id_Call
(Pref
)))));
6374 elsif Restricted_Profile
then
6376 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6380 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6383 Analyze_And_Resolve
(N
, Standard_Boolean
);
6390 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6391 -- unchecked conversion from (integral) type of X to type address. If
6392 -- the To_Address is a static expression, the transformed expression
6393 -- also needs to be static, because we do some legality checks (e.g.
6394 -- for Thread_Local_Storage) after this transformation.
6397 | Attribute_To_Address
6399 To_Address
: declare
6400 Is_Static
: constant Boolean := Is_Static_Expression
(N
);
6404 Unchecked_Convert_To
(RTE
(RE_Address
),
6405 Relocate_Node
(First
(Exprs
))));
6406 Set_Is_Static_Expression
(N
, Is_Static
);
6408 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6415 when Attribute_To_Any
=> To_Any
: declare
6416 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6417 Decls
: constant List_Id
:= New_List
;
6423 Relocate_Node
(First
(Exprs
))), Decls
));
6424 Insert_Actions
(N
, Decls
);
6425 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6432 -- Transforms 'Truncation into a call to the floating-point attribute
6433 -- function Truncation in Fat_xxx (where xxx is the root type).
6434 -- Expansion is avoided for cases the back end can handle directly.
6436 when Attribute_Truncation
=>
6437 if not Is_Inline_Floating_Point_Attribute
(N
) then
6438 Expand_Fpt_Attribute_R
(N
);
6445 when Attribute_TypeCode
=> TypeCode
: declare
6446 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6447 Decls
: constant List_Id
:= New_List
;
6449 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
6450 Insert_Actions
(N
, Decls
);
6451 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6454 -----------------------
6455 -- Unbiased_Rounding --
6456 -----------------------
6458 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6459 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6460 -- root type). Expansion is avoided for cases the back end can handle
6463 when Attribute_Unbiased_Rounding
=>
6464 if not Is_Inline_Floating_Point_Attribute
(N
) then
6465 Expand_Fpt_Attribute_R
(N
);
6472 when Attribute_Update
=>
6473 Expand_Update_Attribute
(N
);
6479 -- The processing for VADS_Size is shared with Size
6485 -- For enumeration types with a standard representation, and for all
6486 -- other types, Val is handled by the back end. For enumeration types
6487 -- with a non-standard representation we use the _Pos_To_Rep array that
6488 -- was created when the type was frozen.
6490 when Attribute_Val
=> Val
: declare
6491 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
6494 if Is_Enumeration_Type
(Etyp
)
6495 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6497 if Has_Contiguous_Rep
(Etyp
) then
6499 Rep_Node
: constant Node_Id
:=
6500 Unchecked_Convert_To
(Etyp
,
6503 Make_Integer_Literal
(Loc
,
6504 Enumeration_Rep
(First_Literal
(Etyp
))),
6506 (Convert_To
(Standard_Integer
,
6507 Relocate_Node
(First
(Exprs
))))));
6511 Unchecked_Convert_To
(Etyp
,
6514 Make_Integer_Literal
(Loc
,
6515 Enumeration_Rep
(First_Literal
(Etyp
))),
6517 Make_Function_Call
(Loc
,
6520 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6521 Parameter_Associations
=> New_List
(
6523 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
6528 Make_Indexed_Component
(Loc
,
6529 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
6530 Expressions
=> New_List
(
6531 Convert_To
(Standard_Integer
,
6532 Relocate_Node
(First
(Exprs
))))));
6535 Analyze_And_Resolve
(N
, Typ
);
6537 -- If the argument is marked as requiring a range check then generate
6540 elsif Do_Range_Check
(First
(Exprs
)) then
6541 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
6549 -- The code for valid is dependent on the particular types involved.
6550 -- See separate sections below for the generated code in each case.
6552 when Attribute_Valid
=> Valid
: declare
6553 PBtyp
: Entity_Id
:= Base_Type
(Ptyp
);
6555 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
6556 -- Save the validity checking mode. We always turn off validity
6557 -- checking during process of 'Valid since this is one place
6558 -- where we do not want the implicit validity checks to interfere
6559 -- with the explicit validity check that the programmer is doing.
6561 function Make_Range_Test
return Node_Id
;
6562 -- Build the code for a range test of the form
6563 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
6565 ---------------------
6566 -- Make_Range_Test --
6567 ---------------------
6569 function Make_Range_Test
return Node_Id
is
6573 -- The prefix of attribute 'Valid should always denote an object
6574 -- reference. The reference is either coming directly from source
6575 -- or is produced by validity check expansion. The object may be
6576 -- wrapped in a conversion in which case the call to Unqual_Conv
6579 -- If the prefix denotes a variable which captures the value of
6580 -- an object for validation purposes, use the variable in the
6581 -- range test. This ensures that no extra copies or extra reads
6582 -- are produced as part of the test. Generate:
6584 -- Temp : ... := Object;
6585 -- if not Temp in ... then
6587 if Is_Validation_Variable_Reference
(Pref
) then
6588 Temp
:= New_Occurrence_Of
(Entity
(Unqual_Conv
(Pref
)), Loc
);
6590 -- Otherwise the prefix is either a source object or a constant
6591 -- produced by validity check expansion. Generate:
6593 -- Temp : constant ... := Pref;
6594 -- if not Temp in ... then
6597 Temp
:= Duplicate_Subexpr
(Pref
);
6602 Left_Opnd
=> Unchecked_Convert_To
(PBtyp
, Temp
),
6606 Unchecked_Convert_To
(PBtyp
,
6607 Make_Attribute_Reference
(Loc
,
6608 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6609 Attribute_Name
=> Name_First
)),
6611 Unchecked_Convert_To
(PBtyp
,
6612 Make_Attribute_Reference
(Loc
,
6613 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6614 Attribute_Name
=> Name_Last
))));
6615 end Make_Range_Test
;
6621 -- Start of processing for Attribute_Valid
6624 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6625 -- will be handled by the back-end directly.
6627 if CodePeer_Mode
and then Comes_From_Source
(N
) then
6631 -- Turn off validity checks. We do not want any implicit validity
6632 -- checks to intefere with the explicit check from the attribute
6634 Validity_Checks_On
:= False;
6636 -- Retrieve the base type. Handle the case where the base type is a
6637 -- private enumeration type.
6639 if Is_Private_Type
(PBtyp
) and then Present
(Full_View
(PBtyp
)) then
6640 PBtyp
:= Full_View
(PBtyp
);
6643 -- Floating-point case. This case is handled by the Valid attribute
6644 -- code in the floating-point attribute run-time library.
6646 if Is_Floating_Point_Type
(Ptyp
) then
6647 Float_Valid
: declare
6651 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
6652 -- Return entity for Pkg.Nam
6654 --------------------
6655 -- Get_Fat_Entity --
6656 --------------------
6658 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
6659 Exp_Name
: constant Node_Id
:=
6660 Make_Selected_Component
(Loc
,
6661 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
6662 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
6664 Find_Selected_Component
(Exp_Name
);
6665 return Entity
(Exp_Name
);
6668 -- Start of processing for Float_Valid
6671 -- The C and AAMP back-ends handle Valid for fpt types
6673 if Modify_Tree_For_C
or else Float_Rep
(PBtyp
) = AAMP
then
6674 Analyze_And_Resolve
(Pref
, Ptyp
);
6675 Set_Etype
(N
, Standard_Boolean
);
6679 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6681 -- If the prefix is a reverse SSO component, or is possibly
6682 -- unaligned, first create a temporary copy that is in
6683 -- native SSO, and properly aligned. Make it Volatile to
6684 -- prevent folding in the back-end. Note that we use an
6685 -- intermediate constrained string type to initialize the
6686 -- temporary, as the value at hand might be invalid, and in
6687 -- that case it cannot be copied using a floating point
6690 if In_Reverse_Storage_Order_Object
(Pref
)
6691 or else Is_Possibly_Unaligned_Object
(Pref
)
6694 Temp
: constant Entity_Id
:=
6695 Make_Temporary
(Loc
, 'F');
6697 Fat_S
: constant Entity_Id
:=
6698 Get_Fat_Entity
(Name_S
);
6699 -- Constrained string subtype of appropriate size
6701 Fat_P
: constant Entity_Id
:=
6702 Get_Fat_Entity
(Name_P
);
6705 Decl
: constant Node_Id
:=
6706 Make_Object_Declaration
(Loc
,
6707 Defining_Identifier
=> Temp
,
6708 Aliased_Present
=> True,
6709 Object_Definition
=>
6710 New_Occurrence_Of
(Ptyp
, Loc
));
6713 Set_Aspect_Specifications
(Decl
, New_List
(
6714 Make_Aspect_Specification
(Loc
,
6716 Make_Identifier
(Loc
, Name_Volatile
))));
6722 Make_Assignment_Statement
(Loc
,
6724 Make_Explicit_Dereference
(Loc
,
6726 Unchecked_Convert_To
(Fat_P
,
6727 Make_Attribute_Reference
(Loc
,
6729 New_Occurrence_Of
(Temp
, Loc
),
6731 Name_Unrestricted_Access
))),
6733 Unchecked_Convert_To
(Fat_S
,
6734 Relocate_Node
(Pref
)))),
6736 Suppress
=> All_Checks
);
6738 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
6742 -- We now have an object of the proper endianness and
6743 -- alignment, and can construct a Valid attribute.
6745 -- We make sure the prefix of this valid attribute is
6746 -- marked as not coming from source, to avoid losing
6747 -- warnings from 'Valid looking like a possible update.
6749 Set_Comes_From_Source
(Pref
, False);
6751 Expand_Fpt_Attribute
6752 (N
, Pkg
, Name_Valid
,
6754 Make_Attribute_Reference
(Loc
,
6755 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6756 Attribute_Name
=> Name_Unrestricted_Access
)));
6759 -- One more task, we still need a range check. Required
6760 -- only if we have a constraint, since the Valid routine
6761 -- catches infinities properly (infinities are never valid).
6763 -- The way we do the range check is simply to create the
6764 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6766 if not Subtypes_Statically_Match
(Ptyp
, PBtyp
) then
6769 Left_Opnd
=> Relocate_Node
(N
),
6772 Left_Opnd
=> Convert_To
(PBtyp
, Pref
),
6773 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6777 -- Enumeration type with holes
6779 -- For enumeration types with holes, the Pos value constructed by
6780 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6781 -- second argument of False returns minus one for an invalid value,
6782 -- and the non-negative pos value for a valid value, so the
6783 -- expansion of X'Valid is simply:
6785 -- type(X)'Pos (X) >= 0
6787 -- We can't quite generate it that way because of the requirement
6788 -- for the non-standard second argument of False in the resulting
6789 -- rep_to_pos call, so we have to explicitly create:
6791 -- _rep_to_pos (X, False) >= 0
6793 -- If we have an enumeration subtype, we also check that the
6794 -- value is in range:
6796 -- _rep_to_pos (X, False) >= 0
6798 -- (X >= type(X)'First and then type(X)'Last <= X)
6800 elsif Is_Enumeration_Type
(Ptyp
)
6801 and then Present
(Enum_Pos_To_Rep
(PBtyp
))
6806 Make_Function_Call
(Loc
,
6808 New_Occurrence_Of
(TSS
(PBtyp
, TSS_Rep_To_Pos
), Loc
),
6809 Parameter_Associations
=> New_List
(
6811 New_Occurrence_Of
(Standard_False
, Loc
))),
6812 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
6816 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(PBtyp
)
6818 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(PBtyp
))
6820 -- The call to Make_Range_Test will create declarations
6821 -- that need a proper insertion point, but Pref is now
6822 -- attached to a node with no ancestor. Attach to tree
6823 -- even if it is to be rewritten below.
6825 Set_Parent
(Tst
, Parent
(N
));
6829 Left_Opnd
=> Make_Range_Test
,
6835 -- Fortran convention booleans
6837 -- For the very special case of Fortran convention booleans, the
6838 -- value is always valid, since it is an integer with the semantics
6839 -- that non-zero is true, and any value is permissible.
6841 elsif Is_Boolean_Type
(Ptyp
)
6842 and then Convention
(Ptyp
) = Convention_Fortran
6844 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6846 -- For biased representations, we will be doing an unchecked
6847 -- conversion without unbiasing the result. That means that the range
6848 -- test has to take this into account, and the proper form of the
6851 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
6853 elsif Has_Biased_Representation
(Ptyp
) then
6854 PBtyp
:= RTE
(RE_Unsigned_32
);
6858 Unchecked_Convert_To
(PBtyp
, Duplicate_Subexpr
(Pref
)),
6860 Unchecked_Convert_To
(PBtyp
,
6861 Make_Attribute_Reference
(Loc
,
6862 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6863 Attribute_Name
=> Name_Range_Length
))));
6865 -- For all other scalar types, what we want logically is a
6868 -- X in type(X)'First .. type(X)'Last
6870 -- But that's precisely what won't work because of possible
6871 -- unwanted optimization (and indeed the basic motivation for
6872 -- the Valid attribute is exactly that this test does not work).
6873 -- What will work is:
6875 -- PBtyp!(X) >= PBtyp!(type(X)'First)
6877 -- PBtyp!(X) <= PBtyp!(type(X)'Last)
6879 -- where PBtyp is an integer type large enough to cover the full
6880 -- range of possible stored values (i.e. it is chosen on the basis
6881 -- of the size of the type, not the range of the values). We write
6882 -- this as two tests, rather than a range check, so that static
6883 -- evaluation will easily remove either or both of the checks if
6884 -- they can be -statically determined to be true (this happens
6885 -- when the type of X is static and the range extends to the full
6886 -- range of stored values).
6888 -- Unsigned types. Note: it is safe to consider only whether the
6889 -- subtype is unsigned, since we will in that case be doing all
6890 -- unsigned comparisons based on the subtype range. Since we use the
6891 -- actual subtype object size, this is appropriate.
6893 -- For example, if we have
6895 -- subtype x is integer range 1 .. 200;
6896 -- for x'Object_Size use 8;
6898 -- Now the base type is signed, but objects of this type are bits
6899 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6900 -- correct, even though a value greater than 127 looks signed to a
6901 -- signed comparison.
6903 elsif Is_Unsigned_Type
(Ptyp
)
6904 or else (Is_Private_Type
(Ptyp
) and then Is_Unsigned_Type
(Btyp
))
6906 if Esize
(Ptyp
) <= 32 then
6907 PBtyp
:= RTE
(RE_Unsigned_32
);
6909 PBtyp
:= RTE
(RE_Unsigned_64
);
6912 Rewrite
(N
, Make_Range_Test
);
6917 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6918 PBtyp
:= Standard_Integer
;
6920 PBtyp
:= Universal_Integer
;
6923 Rewrite
(N
, Make_Range_Test
);
6926 -- If a predicate is present, then we do the predicate test, even if
6927 -- within the predicate function (infinite recursion is warned about
6928 -- in Sem_Attr in that case).
6931 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6934 if Present
(Pred_Func
) then
6937 Left_Opnd
=> Relocate_Node
(N
),
6938 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6942 Analyze_And_Resolve
(N
, Standard_Boolean
);
6943 Validity_Checks_On
:= Save_Validity_Checks_On
;
6950 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6951 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
6952 Comp_Typ
: Entity_Id
;
6956 -- Assume that the prefix does not need validation
6960 -- Attribute 'Valid_Scalars is not supported on private tagged types
6962 if Is_Private_Type
(Ptyp
) and then Is_Tagged_Type
(Ptyp
) then
6965 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
6968 elsif not Scalar_Part_Present
(Val_Typ
) then
6971 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
6972 -- validated type is a scalar type. Generate:
6974 -- Val_Typ (Pref)'Valid
6976 elsif Is_Scalar_Type
(Val_Typ
) then
6978 Make_Attribute_Reference
(Loc
,
6980 Unchecked_Convert_To
(Val_Typ
, New_Copy_Tree
(Pref
)),
6981 Attribute_Name
=> Name_Valid
);
6983 -- Validate the scalar components of an array by iterating over all
6984 -- dimensions of the array while checking individual components.
6986 elsif Is_Array_Type
(Val_Typ
) then
6987 Comp_Typ
:= Validated_View
(Component_Type
(Val_Typ
));
6989 if Scalar_Part_Present
(Comp_Typ
) then
6991 Make_Function_Call
(Loc
,
6994 (Build_Array_VS_Func
6997 Array_Typ
=> Val_Typ
,
6998 Comp_Typ
=> Comp_Typ
),
7000 Parameter_Associations
=> New_List
(Pref
));
7003 -- Validate the scalar components, discriminants of a record type by
7004 -- examining the structure of a record type.
7006 elsif Is_Record_Type
(Val_Typ
) then
7008 Make_Function_Call
(Loc
,
7011 (Build_Record_VS_Func
7014 Rec_Typ
=> Val_Typ
),
7016 Parameter_Associations
=> New_List
(Pref
));
7019 -- Default the attribute to True when the type of the prefix does not
7023 Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
7027 Analyze_And_Resolve
(N
, Standard_Boolean
);
7028 Set_Is_Static_Expression
(N
, False);
7035 -- Value attribute is handled in separate unit Exp_Imgv
7037 when Attribute_Value
=>
7038 Exp_Imgv
.Expand_Value_Attribute
(N
);
7044 -- The processing for Value_Size shares the processing for Size
7050 -- The processing for Version shares the processing for Body_Version
7056 -- Wide_Image attribute is handled in separate unit Exp_Imgv
7058 when Attribute_Wide_Image
=>
7059 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7060 -- back-end knows how to handle this attribute directly.
7062 if CodePeer_Mode
then
7066 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
7068 ---------------------
7069 -- Wide_Wide_Image --
7070 ---------------------
7072 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7074 when Attribute_Wide_Wide_Image
=>
7075 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7076 -- back-end knows how to handle this attribute directly.
7078 if CodePeer_Mode
then
7082 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7088 -- We expand typ'Wide_Value (X) into
7091 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7093 -- Wide_String_To_String is a runtime function that converts its wide
7094 -- string argument to String, converting any non-translatable characters
7095 -- into appropriate escape sequences. This preserves the required
7096 -- semantics of Wide_Value in all cases, and results in a very simple
7097 -- implementation approach.
7099 -- Note: for this approach to be fully standard compliant for the cases
7100 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7101 -- method must cover the entire character range (e.g. UTF-8). But that
7102 -- is a reasonable requirement when dealing with encoded character
7103 -- sequences. Presumably if one of the restrictive encoding mechanisms
7104 -- is in use such as Shift-JIS, then characters that cannot be
7105 -- represented using this encoding will not appear in any case.
7107 when Attribute_Wide_Value
=>
7109 Make_Attribute_Reference
(Loc
,
7111 Attribute_Name
=> Name_Value
,
7113 Expressions
=> New_List
(
7114 Make_Function_Call
(Loc
,
7116 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7118 Parameter_Associations
=> New_List
(
7119 Relocate_Node
(First
(Exprs
)),
7120 Make_Integer_Literal
(Loc
,
7121 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7123 Analyze_And_Resolve
(N
, Typ
);
7125 ---------------------
7126 -- Wide_Wide_Value --
7127 ---------------------
7129 -- We expand typ'Wide_Value_Value (X) into
7132 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7134 -- Wide_Wide_String_To_String is a runtime function that converts its
7135 -- wide string argument to String, converting any non-translatable
7136 -- characters into appropriate escape sequences. This preserves the
7137 -- required semantics of Wide_Wide_Value in all cases, and results in a
7138 -- very simple implementation approach.
7140 -- It's not quite right where typ = Wide_Wide_Character, because the
7141 -- encoding method may not cover the whole character type ???
7143 when Attribute_Wide_Wide_Value
=>
7145 Make_Attribute_Reference
(Loc
,
7147 Attribute_Name
=> Name_Value
,
7149 Expressions
=> New_List
(
7150 Make_Function_Call
(Loc
,
7153 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7155 Parameter_Associations
=> New_List
(
7156 Relocate_Node
(First
(Exprs
)),
7157 Make_Integer_Literal
(Loc
,
7158 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7160 Analyze_And_Resolve
(N
, Typ
);
7162 ---------------------
7163 -- Wide_Wide_Width --
7164 ---------------------
7166 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7168 when Attribute_Wide_Wide_Width
=>
7169 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7175 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7177 when Attribute_Wide_Width
=>
7178 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7184 -- Width attribute is handled in separate unit Exp_Imgv
7186 when Attribute_Width
=>
7187 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7193 when Attribute_Write
=> Write
: declare
7194 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7195 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7203 -- If no underlying type, we have an error that will be diagnosed
7204 -- elsewhere, so here we just completely ignore the expansion.
7210 -- Stream operations can appear in user code even if the restriction
7211 -- No_Streams is active (for example, when instantiating a predefined
7212 -- container). In that case rewrite the attribute as a Raise to
7213 -- prevent any run-time use.
7215 if Restriction_Active
(No_Streams
) then
7217 Make_Raise_Program_Error
(Sloc
(N
),
7218 Reason
=> PE_Stream_Operation_Not_Allowed
));
7219 Set_Etype
(N
, U_Type
);
7223 -- The simple case, if there is a TSS for Write, just call it
7225 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7227 if Present
(Pname
) then
7231 -- If there is a Stream_Convert pragma, use it, we rewrite
7233 -- sourcetyp'Output (stream, Item)
7237 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7239 -- where strmwrite is the given Write function that converts an
7240 -- argument of type sourcetyp or a type acctyp, from which it is
7241 -- derived to type strmtyp. The conversion to acttyp is required
7242 -- for the derived case.
7244 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7246 if Present
(Prag
) then
7248 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7249 Wfunc
:= Entity
(Expression
(Arg3
));
7252 Make_Attribute_Reference
(Loc
,
7253 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7254 Attribute_Name
=> Name_Output
,
7255 Expressions
=> New_List
(
7256 Relocate_Node
(First
(Exprs
)),
7257 Make_Function_Call
(Loc
,
7258 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7259 Parameter_Associations
=> New_List
(
7260 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7261 Relocate_Node
(Next
(First
(Exprs
)))))))));
7266 -- For elementary types, we call the W_xxx routine directly
7268 elsif Is_Elementary_Type
(U_Type
) then
7269 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7275 elsif Is_Array_Type
(U_Type
) then
7276 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7277 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
7279 -- Tagged type case, use the primitive Write function. Note that
7280 -- this will dispatch in the class-wide case which is what we want
7282 elsif Is_Tagged_Type
(U_Type
) then
7283 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7285 -- All other record type cases, including protected records.
7286 -- The latter only arise for expander generated code for
7287 -- handling shared passive partition access.
7291 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7293 -- Ada 2005 (AI-216): Program_Error is raised when executing
7294 -- the default implementation of the Write attribute of an
7295 -- Unchecked_Union type. However, if the 'Write reference is
7296 -- within the generated Output stream procedure, Write outputs
7297 -- the components, and the default values of the discriminant
7298 -- are streamed by the Output procedure itself. If there are
7299 -- no default values this is also erroneous.
7301 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
7302 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7303 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
7304 or else No
(Discriminant_Default_Value
7305 (First_Discriminant
(U_Type
)))
7308 Make_Raise_Program_Error
(Loc
,
7309 Reason
=> PE_Unchecked_Union_Restriction
));
7310 Set_Etype
(N
, U_Type
);
7315 if Has_Discriminants
(U_Type
)
7317 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
7319 Build_Mutable_Record_Write_Procedure
7320 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7322 Build_Record_Write_Procedure
7323 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7326 Insert_Action
(N
, Decl
);
7330 -- If we fall through, Pname is the procedure to be called
7332 Rewrite_Stream_Proc_Call
(Pname
);
7335 -- Component_Size is handled by the back end, unless the component size
7336 -- is known at compile time, which is always true in the packed array
7337 -- case. It is important that the packed array case is handled in the
7338 -- front end (see Eval_Attribute) since the back end would otherwise get
7339 -- confused by the equivalent packed array type.
7341 when Attribute_Component_Size
=>
7344 -- The following attributes are handled by the back end (except that
7345 -- static cases have already been evaluated during semantic processing,
7346 -- but in any case the back end should not count on this).
7348 -- The back end also handles the non-class-wide cases of Size
7350 when Attribute_Bit_Order
7351 | Attribute_Code_Address
7352 | Attribute_Definite
7354 | Attribute_Null_Parameter
7355 | Attribute_Passed_By_Reference
7356 | Attribute_Pool_Address
7357 | Attribute_Scalar_Storage_Order
7361 -- The following attributes are also handled by the back end, but return
7362 -- a universal integer result, so may need a conversion for checking
7363 -- that the result is in range.
7366 | Attribute_Max_Alignment_For_Allocation
7368 Apply_Universal_Integer_Attribute_Checks
(N
);
7370 -- The following attributes should not appear at this stage, since they
7371 -- have already been handled by the analyzer (and properly rewritten
7372 -- with corresponding values or entities to represent the right values)
7374 when Attribute_Abort_Signal
7375 | Attribute_Address_Size
7376 | Attribute_Atomic_Always_Lock_Free
7379 | Attribute_Compiler_Version
7380 | Attribute_Default_Bit_Order
7381 | Attribute_Default_Scalar_Storage_Order
7388 | Attribute_Fast_Math
7389 | Attribute_First_Valid
7390 | Attribute_Has_Access_Values
7391 | Attribute_Has_Discriminants
7392 | Attribute_Has_Tagged_Values
7394 | Attribute_Last_Valid
7395 | Attribute_Library_Level
7396 | Attribute_Lock_Free
7397 | Attribute_Machine_Emax
7398 | Attribute_Machine_Emin
7399 | Attribute_Machine_Mantissa
7400 | Attribute_Machine_Overflows
7401 | Attribute_Machine_Radix
7402 | Attribute_Machine_Rounds
7403 | Attribute_Maximum_Alignment
7404 | Attribute_Model_Emin
7405 | Attribute_Model_Epsilon
7406 | Attribute_Model_Mantissa
7407 | Attribute_Model_Small
7409 | Attribute_Partition_ID
7411 | Attribute_Restriction_Set
7412 | Attribute_Safe_Emax
7413 | Attribute_Safe_First
7414 | Attribute_Safe_Large
7415 | Attribute_Safe_Last
7416 | Attribute_Safe_Small
7418 | Attribute_Signed_Zeros
7420 | Attribute_Storage_Unit
7421 | Attribute_Stub_Type
7422 | Attribute_System_Allocator_Alignment
7423 | Attribute_Target_Name
7424 | Attribute_Type_Class
7425 | Attribute_Type_Key
7426 | Attribute_Unconstrained_Array
7427 | Attribute_Universal_Literal_String
7428 | Attribute_Wchar_T_Size
7429 | Attribute_Word_Size
7431 raise Program_Error
;
7433 -- The Asm_Input and Asm_Output attributes are not expanded at this
7434 -- stage, but will be eliminated in the expansion of the Asm call, see
7435 -- Exp_Intr for details. So the back end will never see these either.
7437 when Attribute_Asm_Input
7438 | Attribute_Asm_Output
7443 -- Note: as mentioned earlier, individual sections of the above case
7444 -- statement assume there is no code after the case statement, and are
7445 -- legitimately allowed to execute return statements if they have nothing
7446 -- more to do, so DO NOT add code at this point.
7449 when RE_Not_Available
=>
7451 end Expand_N_Attribute_Reference
;
7453 --------------------------------
7454 -- Expand_Pred_Succ_Attribute --
7455 --------------------------------
7457 -- For typ'Pred (exp), we generate the check
7459 -- [constraint_error when exp = typ'Base'First]
7461 -- Similarly, for typ'Succ (exp), we generate the check
7463 -- [constraint_error when exp = typ'Base'Last]
7465 -- These checks are not generated for modular types, since the proper
7466 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7467 -- We also suppress these checks if we are the right side of an assignment
7468 -- statement or the expression of an object declaration, where the flag
7469 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7471 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
7472 Loc
: constant Source_Ptr
:= Sloc
(N
);
7473 P
: constant Node_Id
:= Parent
(N
);
7477 if Attribute_Name
(N
) = Name_Pred
then
7483 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
7484 or else not Suppress_Assignment_Checks
(P
)
7487 Make_Raise_Constraint_Error
(Loc
,
7491 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
7493 Make_Attribute_Reference
(Loc
,
7495 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
7496 Attribute_Name
=> Cnam
)),
7497 Reason
=> CE_Overflow_Check_Failed
));
7499 end Expand_Pred_Succ_Attribute
;
7501 ---------------------------
7502 -- Expand_Size_Attribute --
7503 ---------------------------
7505 procedure Expand_Size_Attribute
(N
: Node_Id
) is
7506 Loc
: constant Source_Ptr
:= Sloc
(N
);
7507 Typ
: constant Entity_Id
:= Etype
(N
);
7508 Pref
: constant Node_Id
:= Prefix
(N
);
7509 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
7510 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
7514 -- Case of known RM_Size of a type
7516 if (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
7517 and then Is_Entity_Name
(Pref
)
7518 and then Is_Type
(Entity
(Pref
))
7519 and then Known_Static_RM_Size
(Entity
(Pref
))
7521 Siz
:= RM_Size
(Entity
(Pref
));
7523 -- Case of known Esize of a type
7525 elsif Id
= Attribute_Object_Size
7526 and then Is_Entity_Name
(Pref
)
7527 and then Is_Type
(Entity
(Pref
))
7528 and then Known_Static_Esize
(Entity
(Pref
))
7530 Siz
:= Esize
(Entity
(Pref
));
7532 -- Case of known size of object
7534 elsif Id
= Attribute_Size
7535 and then Is_Entity_Name
(Pref
)
7536 and then Is_Object
(Entity
(Pref
))
7537 and then Known_Esize
(Entity
(Pref
))
7538 and then Known_Static_Esize
(Entity
(Pref
))
7540 Siz
:= Esize
(Entity
(Pref
));
7542 -- For an array component, we can do Size in the front end if the
7543 -- component_size of the array is set.
7545 elsif Nkind
(Pref
) = N_Indexed_Component
then
7546 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
7548 -- For a record component, we can do Size in the front end if there is a
7549 -- component clause, or if the record is packed and the component's size
7550 -- is known at compile time.
7552 elsif Nkind
(Pref
) = N_Selected_Component
then
7554 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
7555 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
7558 if Present
(Component_Clause
(Comp
)) then
7559 Siz
:= Esize
(Comp
);
7561 elsif Is_Packed
(Rec
) then
7562 Siz
:= RM_Size
(Ptyp
);
7565 Apply_Universal_Integer_Attribute_Checks
(N
);
7570 -- All other cases are handled by the back end
7573 -- If Size is applied to a formal parameter that is of a packed
7574 -- array subtype, then apply Size to the actual subtype.
7576 if Is_Entity_Name
(Pref
)
7577 and then Is_Formal
(Entity
(Pref
))
7578 and then Is_Array_Type
(Ptyp
)
7579 and then Is_Packed
(Ptyp
)
7582 Make_Attribute_Reference
(Loc
,
7584 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
7585 Attribute_Name
=> Name_Size
));
7586 Analyze_And_Resolve
(N
, Typ
);
7588 -- If Size is applied to a dereference of an access to unconstrained
7589 -- packed array, the back end needs to see its unconstrained nominal
7590 -- type, but also a hint to the actual constrained type.
7592 elsif Nkind
(Pref
) = N_Explicit_Dereference
7593 and then Is_Array_Type
(Ptyp
)
7594 and then not Is_Constrained
(Ptyp
)
7595 and then Is_Packed
(Ptyp
)
7597 Set_Actual_Designated_Subtype
(Pref
, Get_Actual_Subtype
(Pref
));
7599 -- If Size was applied to a slice of a bit-packed array, we rewrite
7600 -- it into the product of Length and Component_Size. We need to do so
7601 -- because bit-packed arrays are represented internally as arrays of
7602 -- System.Unsigned_Types.Packed_Byte for code generation purposes so
7603 -- the size is always rounded up in the back end.
7605 elsif Nkind
(Pref
) = N_Slice
and then Is_Bit_Packed_Array
(Ptyp
) then
7607 Make_Op_Multiply
(Loc
,
7608 Make_Attribute_Reference
(Loc
,
7609 Prefix
=> Duplicate_Subexpr
(Pref
, True),
7610 Attribute_Name
=> Name_Length
),
7611 Make_Attribute_Reference
(Loc
,
7612 Prefix
=> Duplicate_Subexpr
(Pref
, True),
7613 Attribute_Name
=> Name_Component_Size
)));
7614 Analyze_And_Resolve
(N
, Typ
);
7617 -- Apply the required checks last, after rewriting has taken place
7619 Apply_Universal_Integer_Attribute_Checks
(N
);
7623 -- Common processing for record and array component case
7625 if Siz
/= No_Uint
and then Siz
/= 0 then
7627 CS
: constant Boolean := Comes_From_Source
(N
);
7630 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
7632 -- This integer literal is not a static expression. We do not
7633 -- call Analyze_And_Resolve here, because this would activate
7634 -- the circuit for deciding that a static value was out of range,
7635 -- and we don't want that.
7637 -- So just manually set the type, mark the expression as
7638 -- nonstatic, and then ensure that the result is checked
7639 -- properly if the attribute comes from source (if it was
7640 -- internally generated, we never need a constraint check).
7643 Set_Is_Static_Expression
(N
, False);
7646 Apply_Constraint_Check
(N
, Typ
);
7650 end Expand_Size_Attribute
;
7652 -----------------------------
7653 -- Expand_Update_Attribute --
7654 -----------------------------
7656 procedure Expand_Update_Attribute
(N
: Node_Id
) is
7657 procedure Process_Component_Or_Element_Update
7662 -- Generate the statements necessary to update a single component or an
7663 -- element of the prefix. The code is inserted before the attribute N.
7664 -- Temp denotes the entity of the anonymous object created to reflect
7665 -- the changes in values. Comp is the component/index expression to be
7666 -- updated. Expr is an expression yielding the new value of Comp. Typ
7667 -- is the type of the prefix of attribute Update.
7669 procedure Process_Range_Update
7674 -- Generate the statements necessary to update a slice of the prefix.
7675 -- The code is inserted before the attribute N. Temp denotes the entity
7676 -- of the anonymous object created to reflect the changes in values.
7677 -- Comp is range of the slice to be updated. Expr is an expression
7678 -- yielding the new value of Comp. Typ is the type of the prefix of
7679 -- attribute Update.
7681 -----------------------------------------
7682 -- Process_Component_Or_Element_Update --
7683 -----------------------------------------
7685 procedure Process_Component_Or_Element_Update
7691 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7696 -- An array element may be modified by the following relations
7697 -- depending on the number of dimensions:
7699 -- 1 => Expr -- one dimensional update
7700 -- (1, ..., N) => Expr -- multi dimensional update
7702 -- The above forms are converted in assignment statements where the
7703 -- left hand side is an indexed component:
7705 -- Temp (1) := Expr; -- one dimensional update
7706 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7708 if Is_Array_Type
(Typ
) then
7710 -- The index expressions of a multi dimensional array update
7711 -- appear as an aggregate.
7713 if Nkind
(Comp
) = N_Aggregate
then
7714 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
7716 Exprs
:= New_List
(Relocate_Node
(Comp
));
7720 Make_Indexed_Component
(Loc
,
7721 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7722 Expressions
=> Exprs
);
7724 -- A record component update appears in the following form:
7728 -- The above relation is transformed into an assignment statement
7729 -- where the left hand side is a selected component:
7731 -- Temp.Comp := Expr;
7733 else pragma Assert
(Is_Record_Type
(Typ
));
7735 Make_Selected_Component
(Loc
,
7736 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7737 Selector_Name
=> Relocate_Node
(Comp
));
7741 Make_Assignment_Statement
(Loc
,
7743 Expression
=> Relocate_Node
(Expr
)));
7744 end Process_Component_Or_Element_Update
;
7746 --------------------------
7747 -- Process_Range_Update --
7748 --------------------------
7750 procedure Process_Range_Update
7756 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
7757 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7761 -- A range update appears as
7763 -- (Low .. High => Expr)
7765 -- The above construct is transformed into a loop that iterates over
7766 -- the given range and modifies the corresponding array values to the
7769 -- for Index in Low .. High loop
7770 -- Temp (<Index_Typ> (Index)) := Expr;
7773 Index
:= Make_Temporary
(Loc
, 'I');
7776 Make_Loop_Statement
(Loc
,
7778 Make_Iteration_Scheme
(Loc
,
7779 Loop_Parameter_Specification
=>
7780 Make_Loop_Parameter_Specification
(Loc
,
7781 Defining_Identifier
=> Index
,
7782 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
7784 Statements
=> New_List
(
7785 Make_Assignment_Statement
(Loc
,
7787 Make_Indexed_Component
(Loc
,
7788 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7789 Expressions
=> New_List
(
7790 Convert_To
(Index_Typ
,
7791 New_Occurrence_Of
(Index
, Loc
)))),
7792 Expression
=> Relocate_Node
(Expr
))),
7794 End_Label
=> Empty
));
7795 end Process_Range_Update
;
7799 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
7800 Loc
: constant Source_Ptr
:= Sloc
(N
);
7801 Pref
: constant Node_Id
:= Prefix
(N
);
7802 Typ
: constant Entity_Id
:= Etype
(Pref
);
7805 CW_Temp
: Entity_Id
;
7810 -- Start of processing for Expand_Update_Attribute
7813 -- Create the anonymous object to store the value of the prefix and
7814 -- capture subsequent changes in value.
7816 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
7818 -- Preserve the tag of the prefix by offering a specific view of the
7819 -- class-wide version of the prefix.
7821 if Is_Tagged_Type
(Typ
) then
7824 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7826 CW_Temp
:= Make_Temporary
(Loc
, 'T');
7827 CW_Typ
:= Class_Wide_Type
(Typ
);
7830 Make_Object_Declaration
(Loc
,
7831 Defining_Identifier
=> CW_Temp
,
7832 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
7834 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
7837 -- Temp : Typ renames Typ (CW_Temp);
7840 Make_Object_Renaming_Declaration
(Loc
,
7841 Defining_Identifier
=> Temp
,
7842 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
7844 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
7850 -- Temp : Typ := Pref;
7853 Make_Object_Declaration
(Loc
,
7854 Defining_Identifier
=> Temp
,
7855 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7856 Expression
=> Relocate_Node
(Pref
)));
7859 -- Process the update aggregate
7861 Assoc
:= First
(Component_Associations
(Aggr
));
7862 while Present
(Assoc
) loop
7863 Comp
:= First
(Choices
(Assoc
));
7864 Expr
:= Expression
(Assoc
);
7865 while Present
(Comp
) loop
7866 if Nkind
(Comp
) = N_Range
then
7867 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
7869 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
7878 -- The attribute is replaced by a reference to the anonymous object
7880 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7882 end Expand_Update_Attribute
;
7888 procedure Find_Fat_Info
7890 Fat_Type
: out Entity_Id
;
7891 Fat_Pkg
: out RE_Id
)
7893 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
7896 -- All we do is use the root type (historically this dealt with
7897 -- VAX-float .. to be cleaned up further later ???)
7901 if Fat_Type
= Standard_Short_Float
then
7902 Fat_Pkg
:= RE_Attr_Short_Float
;
7904 elsif Fat_Type
= Standard_Float
then
7905 Fat_Pkg
:= RE_Attr_Float
;
7907 elsif Fat_Type
= Standard_Long_Float
then
7908 Fat_Pkg
:= RE_Attr_Long_Float
;
7910 elsif Fat_Type
= Standard_Long_Long_Float
then
7911 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7913 -- Universal real (which is its own root type) is treated as being
7914 -- equivalent to Standard.Long_Long_Float, since it is defined to
7915 -- have the same precision as the longest Float type.
7917 elsif Fat_Type
= Universal_Real
then
7918 Fat_Type
:= Standard_Long_Long_Float
;
7919 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7922 raise Program_Error
;
7926 ----------------------------
7927 -- Find_Stream_Subprogram --
7928 ----------------------------
7930 function Find_Stream_Subprogram
7932 Nam
: TSS_Name_Type
) return Entity_Id
7934 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7935 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
7937 if Present
(Ent
) then
7941 -- Stream attributes for strings are expanded into library calls. The
7942 -- following checks are disabled when the run-time is not available or
7943 -- when compiling predefined types due to bootstrap issues. As a result,
7944 -- the compiler will generate in-place stream routines for string types
7945 -- that appear in GNAT's library, but will generate calls via rtsfind
7946 -- to library routines for user code.
7948 -- Note: In the case of using a configurable run time, it is very likely
7949 -- that stream routines for string types are not present (they require
7950 -- file system support). In this case, the specific stream routines for
7951 -- strings are not used, relying on the regular stream mechanism
7952 -- instead. That is why we include the test RTE_Available when dealing
7953 -- with these cases.
7955 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
7956 -- Storage_Array as defined in package System.Storage_Elements
7958 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
7960 -- Case of No_Stream_Optimizations restriction active
7962 if Restriction_Active
(No_Stream_Optimizations
) then
7963 if Nam
= TSS_Stream_Input
7964 and then RTE_Available
(RE_Storage_Array_Input
)
7966 return RTE
(RE_Storage_Array_Input
);
7968 elsif Nam
= TSS_Stream_Output
7969 and then RTE_Available
(RE_Storage_Array_Output
)
7971 return RTE
(RE_Storage_Array_Output
);
7973 elsif Nam
= TSS_Stream_Read
7974 and then RTE_Available
(RE_Storage_Array_Read
)
7976 return RTE
(RE_Storage_Array_Read
);
7978 elsif Nam
= TSS_Stream_Write
7979 and then RTE_Available
(RE_Storage_Array_Write
)
7981 return RTE
(RE_Storage_Array_Write
);
7983 elsif Nam
/= TSS_Stream_Input
and then
7984 Nam
/= TSS_Stream_Output
and then
7985 Nam
/= TSS_Stream_Read
and then
7986 Nam
/= TSS_Stream_Write
7988 raise Program_Error
;
7991 -- Restriction No_Stream_Optimizations is not set, so we can go
7992 -- ahead and optimize using the block IO forms of the routines.
7995 if Nam
= TSS_Stream_Input
7996 and then RTE_Available
(RE_Storage_Array_Input_Blk_IO
)
7998 return RTE
(RE_Storage_Array_Input_Blk_IO
);
8000 elsif Nam
= TSS_Stream_Output
8001 and then RTE_Available
(RE_Storage_Array_Output_Blk_IO
)
8003 return RTE
(RE_Storage_Array_Output_Blk_IO
);
8005 elsif Nam
= TSS_Stream_Read
8006 and then RTE_Available
(RE_Storage_Array_Read_Blk_IO
)
8008 return RTE
(RE_Storage_Array_Read_Blk_IO
);
8010 elsif Nam
= TSS_Stream_Write
8011 and then RTE_Available
(RE_Storage_Array_Write_Blk_IO
)
8013 return RTE
(RE_Storage_Array_Write_Blk_IO
);
8015 elsif Nam
/= TSS_Stream_Input
and then
8016 Nam
/= TSS_Stream_Output
and then
8017 Nam
/= TSS_Stream_Read
and then
8018 Nam
/= TSS_Stream_Write
8020 raise Program_Error
;
8024 -- Stream_Element_Array as defined in package Ada.Streams
8026 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
8028 -- Case of No_Stream_Optimizations restriction active
8030 if Restriction_Active
(No_Stream_Optimizations
) then
8031 if Nam
= TSS_Stream_Input
8032 and then RTE_Available
(RE_Stream_Element_Array_Input
)
8034 return RTE
(RE_Stream_Element_Array_Input
);
8036 elsif Nam
= TSS_Stream_Output
8037 and then RTE_Available
(RE_Stream_Element_Array_Output
)
8039 return RTE
(RE_Stream_Element_Array_Output
);
8041 elsif Nam
= TSS_Stream_Read
8042 and then RTE_Available
(RE_Stream_Element_Array_Read
)
8044 return RTE
(RE_Stream_Element_Array_Read
);
8046 elsif Nam
= TSS_Stream_Write
8047 and then RTE_Available
(RE_Stream_Element_Array_Write
)
8049 return RTE
(RE_Stream_Element_Array_Write
);
8051 elsif Nam
/= TSS_Stream_Input
and then
8052 Nam
/= TSS_Stream_Output
and then
8053 Nam
/= TSS_Stream_Read
and then
8054 Nam
/= TSS_Stream_Write
8056 raise Program_Error
;
8059 -- Restriction No_Stream_Optimizations is not set, so we can go
8060 -- ahead and optimize using the block IO forms of the routines.
8063 if Nam
= TSS_Stream_Input
8064 and then RTE_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
8066 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
8068 elsif Nam
= TSS_Stream_Output
8069 and then RTE_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
8071 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
8073 elsif Nam
= TSS_Stream_Read
8074 and then RTE_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
8076 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
8078 elsif Nam
= TSS_Stream_Write
8079 and then RTE_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
8081 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
8083 elsif Nam
/= TSS_Stream_Input
and then
8084 Nam
/= TSS_Stream_Output
and then
8085 Nam
/= TSS_Stream_Read
and then
8086 Nam
/= TSS_Stream_Write
8088 raise Program_Error
;
8092 -- String as defined in package Ada
8094 elsif Base_Typ
= Standard_String
then
8096 -- Case of No_Stream_Optimizations restriction active
8098 if Restriction_Active
(No_Stream_Optimizations
) then
8099 if Nam
= TSS_Stream_Input
8100 and then RTE_Available
(RE_String_Input
)
8102 return RTE
(RE_String_Input
);
8104 elsif Nam
= TSS_Stream_Output
8105 and then RTE_Available
(RE_String_Output
)
8107 return RTE
(RE_String_Output
);
8109 elsif Nam
= TSS_Stream_Read
8110 and then RTE_Available
(RE_String_Read
)
8112 return RTE
(RE_String_Read
);
8114 elsif Nam
= TSS_Stream_Write
8115 and then RTE_Available
(RE_String_Write
)
8117 return RTE
(RE_String_Write
);
8119 elsif Nam
/= TSS_Stream_Input
and then
8120 Nam
/= TSS_Stream_Output
and then
8121 Nam
/= TSS_Stream_Read
and then
8122 Nam
/= TSS_Stream_Write
8124 raise Program_Error
;
8127 -- Restriction No_Stream_Optimizations is not set, so we can go
8128 -- ahead and optimize using the block IO forms of the routines.
8131 if Nam
= TSS_Stream_Input
8132 and then RTE_Available
(RE_String_Input_Blk_IO
)
8134 return RTE
(RE_String_Input_Blk_IO
);
8136 elsif Nam
= TSS_Stream_Output
8137 and then RTE_Available
(RE_String_Output_Blk_IO
)
8139 return RTE
(RE_String_Output_Blk_IO
);
8141 elsif Nam
= TSS_Stream_Read
8142 and then RTE_Available
(RE_String_Read_Blk_IO
)
8144 return RTE
(RE_String_Read_Blk_IO
);
8146 elsif Nam
= TSS_Stream_Write
8147 and then RTE_Available
(RE_String_Write_Blk_IO
)
8149 return RTE
(RE_String_Write_Blk_IO
);
8151 elsif Nam
/= TSS_Stream_Input
and then
8152 Nam
/= TSS_Stream_Output
and then
8153 Nam
/= TSS_Stream_Read
and then
8154 Nam
/= TSS_Stream_Write
8156 raise Program_Error
;
8160 -- Wide_String as defined in package Ada
8162 elsif Base_Typ
= Standard_Wide_String
then
8164 -- Case of No_Stream_Optimizations restriction active
8166 if Restriction_Active
(No_Stream_Optimizations
) then
8167 if Nam
= TSS_Stream_Input
8168 and then RTE_Available
(RE_Wide_String_Input
)
8170 return RTE
(RE_Wide_String_Input
);
8172 elsif Nam
= TSS_Stream_Output
8173 and then RTE_Available
(RE_Wide_String_Output
)
8175 return RTE
(RE_Wide_String_Output
);
8177 elsif Nam
= TSS_Stream_Read
8178 and then RTE_Available
(RE_Wide_String_Read
)
8180 return RTE
(RE_Wide_String_Read
);
8182 elsif Nam
= TSS_Stream_Write
8183 and then RTE_Available
(RE_Wide_String_Write
)
8185 return RTE
(RE_Wide_String_Write
);
8187 elsif Nam
/= TSS_Stream_Input
and then
8188 Nam
/= TSS_Stream_Output
and then
8189 Nam
/= TSS_Stream_Read
and then
8190 Nam
/= TSS_Stream_Write
8192 raise Program_Error
;
8195 -- Restriction No_Stream_Optimizations is not set, so we can go
8196 -- ahead and optimize using the block IO forms of the routines.
8199 if Nam
= TSS_Stream_Input
8200 and then RTE_Available
(RE_Wide_String_Input_Blk_IO
)
8202 return RTE
(RE_Wide_String_Input_Blk_IO
);
8204 elsif Nam
= TSS_Stream_Output
8205 and then RTE_Available
(RE_Wide_String_Output_Blk_IO
)
8207 return RTE
(RE_Wide_String_Output_Blk_IO
);
8209 elsif Nam
= TSS_Stream_Read
8210 and then RTE_Available
(RE_Wide_String_Read_Blk_IO
)
8212 return RTE
(RE_Wide_String_Read_Blk_IO
);
8214 elsif Nam
= TSS_Stream_Write
8215 and then RTE_Available
(RE_Wide_String_Write_Blk_IO
)
8217 return RTE
(RE_Wide_String_Write_Blk_IO
);
8219 elsif Nam
/= TSS_Stream_Input
and then
8220 Nam
/= TSS_Stream_Output
and then
8221 Nam
/= TSS_Stream_Read
and then
8222 Nam
/= TSS_Stream_Write
8224 raise Program_Error
;
8228 -- Wide_Wide_String as defined in package Ada
8230 elsif Base_Typ
= Standard_Wide_Wide_String
then
8232 -- Case of No_Stream_Optimizations restriction active
8234 if Restriction_Active
(No_Stream_Optimizations
) then
8235 if Nam
= TSS_Stream_Input
8236 and then RTE_Available
(RE_Wide_Wide_String_Input
)
8238 return RTE
(RE_Wide_Wide_String_Input
);
8240 elsif Nam
= TSS_Stream_Output
8241 and then RTE_Available
(RE_Wide_Wide_String_Output
)
8243 return RTE
(RE_Wide_Wide_String_Output
);
8245 elsif Nam
= TSS_Stream_Read
8246 and then RTE_Available
(RE_Wide_Wide_String_Read
)
8248 return RTE
(RE_Wide_Wide_String_Read
);
8250 elsif Nam
= TSS_Stream_Write
8251 and then RTE_Available
(RE_Wide_Wide_String_Write
)
8253 return RTE
(RE_Wide_Wide_String_Write
);
8255 elsif Nam
/= TSS_Stream_Input
and then
8256 Nam
/= TSS_Stream_Output
and then
8257 Nam
/= TSS_Stream_Read
and then
8258 Nam
/= TSS_Stream_Write
8260 raise Program_Error
;
8263 -- Restriction No_Stream_Optimizations is not set, so we can go
8264 -- ahead and optimize using the block IO forms of the routines.
8267 if Nam
= TSS_Stream_Input
8268 and then RTE_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8270 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8272 elsif Nam
= TSS_Stream_Output
8273 and then RTE_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8275 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8277 elsif Nam
= TSS_Stream_Read
8278 and then RTE_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8280 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8282 elsif Nam
= TSS_Stream_Write
8283 and then RTE_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8285 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8287 elsif Nam
/= TSS_Stream_Input
and then
8288 Nam
/= TSS_Stream_Output
and then
8289 Nam
/= TSS_Stream_Read
and then
8290 Nam
/= TSS_Stream_Write
8292 raise Program_Error
;
8298 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8299 return Find_Prim_Op
(Typ
, Nam
);
8301 return Find_Inherited_TSS
(Typ
, Nam
);
8303 end Find_Stream_Subprogram
;
8309 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8313 BT
:= Base_Type
(T
);
8315 if Is_Private_Type
(BT
)
8316 and then Present
(Full_View
(BT
))
8318 BT
:= Full_View
(BT
);
8324 -----------------------
8325 -- Get_Index_Subtype --
8326 -----------------------
8328 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
8329 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
8334 if Is_Access_Type
(P_Type
) then
8335 P_Type
:= Designated_Type
(P_Type
);
8338 if No
(Expressions
(N
)) then
8341 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
8344 Indx
:= First_Index
(P_Type
);
8350 return Etype
(Indx
);
8351 end Get_Index_Subtype
;
8353 -------------------------------
8354 -- Get_Stream_Convert_Pragma --
8355 -------------------------------
8357 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8362 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8363 -- that a stream convert pragma for a tagged type is not inherited from
8364 -- its parent. Probably what is wrong here is that it is basically
8365 -- incorrect to consider a stream convert pragma to be a representation
8366 -- pragma at all ???
8368 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8369 while Present
(N
) loop
8370 if Nkind
(N
) = N_Pragma
8371 and then Pragma_Name
(N
) = Name_Stream_Convert
8373 -- For tagged types this pragma is not inherited, so we
8374 -- must verify that it is defined for the given type and
8378 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8380 if not Is_Tagged_Type
(T
)
8382 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8392 end Get_Stream_Convert_Pragma
;
8394 ---------------------------------
8395 -- Is_Constrained_Packed_Array --
8396 ---------------------------------
8398 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8399 Arr
: Entity_Id
:= Typ
;
8402 if Is_Access_Type
(Arr
) then
8403 Arr
:= Designated_Type
(Arr
);
8406 return Is_Array_Type
(Arr
)
8407 and then Is_Constrained
(Arr
)
8408 and then Present
(Packed_Array_Impl_Type
(Arr
));
8409 end Is_Constrained_Packed_Array
;
8411 ----------------------------------------
8412 -- Is_Inline_Floating_Point_Attribute --
8413 ----------------------------------------
8415 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8416 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8418 function Is_GCC_Target
return Boolean;
8419 -- Return True if we are using a GCC target/back-end
8420 -- ??? Note: the implementation is kludgy/fragile
8426 function Is_GCC_Target
return Boolean is
8428 return not CodePeer_Mode
8429 and then not Modify_Tree_For_C
;
8432 -- Start of processing for Is_Inline_Floating_Point_Attribute
8435 -- Machine and Model can be expanded by the GCC back end only
8437 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8438 return Is_GCC_Target
;
8440 -- Remaining cases handled by all back ends are Rounding and Truncation
8441 -- when appearing as the operand of a conversion to some integer type.
8443 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8444 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8449 -- Here we are in the integer conversion context. We reuse Rounding for
8450 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
8453 Id
= Attribute_Rounding
8454 or else Id
= Attribute_Machine_Rounding
8455 or else Id
= Attribute_Truncation
;
8456 end Is_Inline_Floating_Point_Attribute
;