1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Exp_Atag
; use Exp_Atag
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch6
; use Exp_Ch6
;
37 with Exp_Ch9
; use Exp_Ch9
;
38 with Exp_Dist
; use Exp_Dist
;
39 with Exp_Imgv
; use Exp_Imgv
;
40 with Exp_Pakd
; use Exp_Pakd
;
41 with Exp_Strm
; use Exp_Strm
;
43 with Exp_Tss
; use Exp_Tss
;
44 with Exp_Util
; use Exp_Util
;
45 with Expander
; use Expander
;
46 with Freeze
; use Freeze
;
47 with Gnatvsn
; use Gnatvsn
;
48 with Itypes
; use Itypes
;
50 with Namet
; use Namet
;
51 with Nmake
; use Nmake
;
52 with Nlists
; use Nlists
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
58 with Sem_Aux
; use Sem_Aux
;
59 with Sem_Ch6
; use Sem_Ch6
;
60 with Sem_Ch7
; use Sem_Ch7
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Eval
; use Sem_Eval
;
63 with Sem_Res
; use Sem_Res
;
64 with Sem_Util
; use Sem_Util
;
65 with Sinfo
; use Sinfo
;
66 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
67 with Sinfo
.Utils
; use Sinfo
.Utils
;
68 with Snames
; use Snames
;
69 with Stand
; use Stand
;
70 with Stringt
; use Stringt
;
71 with Strub
; use Strub
;
72 with Tbuild
; use Tbuild
;
73 with Ttypes
; use Ttypes
;
74 with Uintp
; use Uintp
;
75 with Uname
; use Uname
;
76 with Urealp
; use Urealp
;
77 with Validsw
; use Validsw
;
79 package body Exp_Attr
is
81 -----------------------
82 -- Local Subprograms --
83 -----------------------
85 function Build_Array_VS_Func
87 Formal_Typ
: Entity_Id
;
88 Array_Typ
: Entity_Id
) return Entity_Id
;
89 -- Validate the components of an array type by means of a function. Return
90 -- the entity of the validation function. The parameters are as follows:
92 -- * Attr - the 'Valid_Scalars attribute for which the function is
95 -- * Formal_Typ - the type of the generated function's only formal
98 -- * Array_Typ - the array type whose components are to be validated
100 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
101 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
103 function Build_Record_VS_Func
105 Formal_Typ
: Entity_Id
;
106 Rec_Typ
: Entity_Id
) return Entity_Id
;
107 -- Validate the components, discriminants, and variants of a record type by
108 -- means of a function. Return the entity of the validation function. The
109 -- parameters are as follows:
111 -- * Attr - the 'Valid_Scalars attribute for which the function is
114 -- * Formal_Typ - the type of the generated function's only formal
117 -- * Rec_Typ - the record type whose internals are to be validated
119 procedure Compile_Stream_Body_In_Scope
123 -- The body for a stream subprogram may be generated outside of the scope
124 -- of the type. If the type is fully private, it may depend on the full
125 -- view of other types (e.g. indexes) that are currently private as well.
126 -- We install the declarations of the package in which the type is declared
127 -- before compiling the body in what is its proper environment. The Check
128 -- parameter indicates if checks are to be suppressed for the stream body.
129 -- We suppress checks for array/record reads, since the rule is that these
130 -- are like assignments, out of range values due to uninitialized storage,
131 -- or other invalid values do NOT cause a Constraint_Error to be raised.
132 -- If we are within an instance body all visibility has been established
133 -- already and there is no need to install the package.
135 -- This mechanism is now extended to the component types of the array type,
136 -- when the component type is not in scope and is private, to handle
137 -- properly the case when the full view has defaulted discriminants.
139 -- This special processing is ultimately caused by the fact that the
140 -- compiler lacks a well-defined phase when full views are visible
141 -- everywhere. Having such a separate pass would remove much of the
142 -- special-case code that shuffles partial and full views in the middle
143 -- of semantic analysis and expansion.
145 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean;
147 -- In most cases, references to unavailable streaming attributes
148 -- are rejected at compile time. In some obscure cases involving
149 -- generics and formal derived types, the problem is dealt with at runtime.
151 procedure Expand_Access_To_Protected_Op
155 -- An attribute reference to a protected subprogram is transformed into
156 -- a pair of pointers: one to the object, and one to the operations.
157 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
159 procedure Expand_Fpt_Attribute
164 -- This procedure expands a call to a floating-point attribute function.
165 -- N is the attribute reference node, and Args is a list of arguments to
166 -- be passed to the function call. Pkg identifies the package containing
167 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
168 -- have already been converted to the floating-point type for which Pkg was
169 -- instantiated. The Nam argument is the relevant attribute processing
170 -- routine to be called. This is the same as the attribute name.
172 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
173 -- This procedure expands a call to a floating-point attribute function
174 -- that takes a single floating-point argument. The function to be called
175 -- is always the same as the attribute name.
177 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
178 -- This procedure expands a call to a floating-point attribute function
179 -- that takes one floating-point argument and one integer argument. The
180 -- function to be called is always the same as the attribute name.
182 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
183 -- This procedure expands a call to a floating-point attribute function
184 -- that takes two floating-point arguments. The function to be called
185 -- is always the same as the attribute name.
187 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
188 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
189 -- loop may be converted into a conditional block. See body for details.
191 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
192 -- Handle the expansion of attributes 'Max and 'Min, including expanding
193 -- then out if we are in Modify_Tree_For_C mode.
195 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
196 -- Handles expansion of Pred or Succ attributes for case of non-real
197 -- operand with overflow checking required.
199 procedure Expand_Update_Attribute
(N
: Node_Id
);
200 -- Handle the expansion of attribute Update
202 procedure Find_Fat_Info
204 Fat_Type
: out Entity_Id
;
205 Fat_Pkg
: out RE_Id
);
206 -- Given a floating-point type T, identifies the package containing the
207 -- attributes for this type (returned in Fat_Pkg), and the corresponding
208 -- type for which this package was instantiated from Fat_Gen. Error if T
209 -- is not a floating-point type.
211 function Find_Stream_Subprogram
213 Nam
: TSS_Name_Type
) return Entity_Id
;
214 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
215 -- types, the corresponding primitive operation is looked up, else the
216 -- appropriate TSS from the type itself, or from its closest ancestor
217 -- defining it, is returned. In both cases, inheritance of representation
218 -- aspects is thus taken into account.
220 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
221 -- The stream functions need to examine the underlying representation of
222 -- composite types. In some cases T may be non-private but its base type
223 -- is, in which case the function returns the corresponding full view.
225 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
226 -- Given a type, find a corresponding stream convert pragma that applies to
227 -- the implementation base type of this type (Typ). If found, return the
228 -- pragma node, otherwise return Empty if no pragma is found.
230 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
231 -- Utility for array attributes, returns true on packed constrained
232 -- arrays, and on access to same.
234 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
235 -- Returns true iff the given node refers to an attribute call that
236 -- can be expanded directly by the back end and does not need front end
237 -- expansion. Typically used for rounding and truncation attributes that
238 -- appear directly inside a conversion to integer.
240 -------------------------
241 -- Build_Array_VS_Func --
242 -------------------------
244 function Build_Array_VS_Func
246 Formal_Typ
: Entity_Id
;
247 Array_Typ
: Entity_Id
) return Entity_Id
249 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
250 Comp_Typ
: constant Entity_Id
:=
251 Validated_View
(Component_Type
(Array_Typ
));
253 function Validate_Component
255 Indexes
: List_Id
) return Node_Id
;
256 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
257 -- the entity of the validation parameter. Return the check associated
258 -- with the component.
260 function Validate_Dimension
263 Indexes
: List_Id
) return Node_Id
;
264 -- Process dimension Dim of the array type. Obj_Id denotes the entity
265 -- of the validation parameter. Indexes is a list where each dimension
266 -- deposits its loop variable, which will later identify a component.
267 -- Return the loop associated with the current dimension.
269 ------------------------
270 -- Validate_Component --
271 ------------------------
273 function Validate_Component
275 Indexes
: List_Id
) return Node_Id
280 if Is_Scalar_Type
(Comp_Typ
) then
281 Attr_Nam
:= Name_Valid
;
283 Attr_Nam
:= Name_Valid_Scalars
;
287 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
292 Make_If_Statement
(Loc
,
296 Make_Attribute_Reference
(Loc
,
298 Make_Indexed_Component
(Loc
,
300 Unchecked_Convert_To
(Array_Typ
,
301 New_Occurrence_Of
(Obj_Id
, Loc
)),
302 Expressions
=> Indexes
),
303 Attribute_Name
=> Attr_Nam
)),
305 Then_Statements
=> New_List
(
306 Make_Simple_Return_Statement
(Loc
,
307 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
308 end Validate_Component
;
310 ------------------------
311 -- Validate_Dimension --
312 ------------------------
314 function Validate_Dimension
317 Indexes
: List_Id
) return Node_Id
322 -- Validate the component once all dimensions have produced their
325 if Dim
> Number_Dimensions
(Array_Typ
) then
326 return Validate_Component
(Obj_Id
, Indexes
);
328 -- Process the current dimension
332 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
));
334 Append_To
(Indexes
, New_Occurrence_Of
(Index
, Loc
));
337 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
338 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
339 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
347 Make_Implicit_Loop_Statement
(Attr
,
350 Make_Iteration_Scheme
(Loc
,
351 Loop_Parameter_Specification
=>
352 Make_Loop_Parameter_Specification
(Loc
,
353 Defining_Identifier
=> Index
,
354 Discrete_Subtype_Definition
=>
355 Make_Attribute_Reference
(Loc
,
357 Unchecked_Convert_To
(Array_Typ
,
358 New_Occurrence_Of
(Obj_Id
, Loc
)),
359 Attribute_Name
=> Name_Range
,
360 Expressions
=> New_List
(
361 Make_Integer_Literal
(Loc
, Dim
))))),
362 Statements
=> New_List
(
363 Validate_Dimension
(Obj_Id
, Dim
+ 1, Indexes
)));
365 end Validate_Dimension
;
369 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
370 Indexes
: constant List_Id
:= New_List
;
371 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
374 -- Start of processing for Build_Array_VS_Func
377 Stmts
:= New_List
(Validate_Dimension
(Obj_Id
, 1, Indexes
));
383 Make_Simple_Return_Statement
(Loc
,
384 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
387 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
392 Mutate_Ekind
(Func_Id
, E_Function
);
393 Set_Is_Internal
(Func_Id
);
394 Set_Is_Pure
(Func_Id
);
396 if not Debug_Generated_Code
then
397 Set_Debug_Info_Off
(Func_Id
);
401 Make_Subprogram_Body
(Loc
,
403 Make_Function_Specification
(Loc
,
404 Defining_Unit_Name
=> Func_Id
,
405 Parameter_Specifications
=> New_List
(
406 Make_Parameter_Specification
(Loc
,
407 Defining_Identifier
=> Obj_Id
,
408 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
410 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
411 Declarations
=> New_List
,
412 Handled_Statement_Sequence
=>
413 Make_Handled_Sequence_Of_Statements
(Loc
,
414 Statements
=> Stmts
)));
417 end Build_Array_VS_Func
;
419 ---------------------------------
420 -- Build_Disp_Get_Task_Id_Call --
421 ---------------------------------
423 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
424 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
425 Typ
: constant Entity_Id
:= Etype
(Actual
);
426 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
430 -- _Disp_Get_Task_Id (Actual)
433 Make_Function_Call
(Loc
,
434 Name
=> New_Occurrence_Of
(Subp
, Loc
),
435 Parameter_Associations
=> New_List
(Actual
));
436 end Build_Disp_Get_Task_Id_Call
;
438 --------------------------
439 -- Build_Record_VS_Func --
440 --------------------------
442 function Build_Record_VS_Func
444 Formal_Typ
: Entity_Id
;
445 Rec_Typ
: Entity_Id
) return Entity_Id
447 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
448 -- It generates code only when there are components, discriminants,
449 -- or variant parts to validate.
451 -- NOTE: The routines within Build_Record_VS_Func are intentionally
452 -- unnested to avoid deep indentation of code.
454 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
456 procedure Validate_Component_List
459 Stmts
: in out List_Id
);
460 -- Process all components and variant parts of component list Comp_List.
461 -- Obj_Id denotes the entity of the validation parameter. All new code
462 -- is added to list Stmts.
464 procedure Validate_Field
467 Cond
: in out Node_Id
);
468 -- Process component declaration or discriminant specification Field.
469 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
470 -- an "or else" conditional expression which contains the new code (if
473 procedure Validate_Fields
476 Stmts
: in out List_Id
);
477 -- Process component declarations or discriminant specifications in list
478 -- Fields. Obj_Id denotes the entity of the validation parameter. All
479 -- new code is added to list Stmts.
481 procedure Validate_Variant
484 Alts
: in out List_Id
);
485 -- Process variant Var. Obj_Id denotes the entity of the validation
486 -- parameter. Alts denotes a list of case statement alternatives which
487 -- contains the new code (if any).
489 procedure Validate_Variant_Part
492 Stmts
: in out List_Id
);
493 -- Process variant part Var_Part. Obj_Id denotes the entity of the
494 -- validation parameter. All new code is added to list Stmts.
496 -----------------------------
497 -- Validate_Component_List --
498 -----------------------------
500 procedure Validate_Component_List
503 Stmts
: in out List_Id
)
505 Var_Part
: constant Node_Id
:= Variant_Part
(Comp_List
);
508 -- Validate all components
512 Fields
=> Component_Items
(Comp_List
),
515 -- Validate the variant part
517 if Present
(Var_Part
) then
518 Validate_Variant_Part
520 Var_Part
=> Var_Part
,
523 end Validate_Component_List
;
529 procedure Validate_Field
532 Cond
: in out Node_Id
)
534 Field_Id
: constant Entity_Id
:= Defining_Entity
(Field
);
535 Field_Nam
: constant Name_Id
:= Chars
(Field_Id
);
536 Field_Typ
: constant Entity_Id
:= Validated_View
(Etype
(Field_Id
));
540 -- Do not process internally-generated fields. Note that checking for
541 -- Comes_From_Source is not correct because this will eliminate the
542 -- components within the corresponding record of a protected type.
544 if Field_Nam
in Name_uObject | Name_uParent | Name_uTag
then
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
738 Typ
:= Validated_View
(Rec_Typ
);
740 -- Use the root type when dealing with a class-wide type
742 if Is_Class_Wide_Type
(Typ
) then
743 Typ
:= Validated_View
(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 Mutate_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
870 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
871 Curr
: constant Entity_Id
:= Current_Scope
;
872 Install
: Boolean := False;
873 Scop
: Entity_Id
:= Scope
(Arr
);
877 and then not In_Open_Scopes
(Scop
)
878 and then Ekind
(Scop
) = E_Package
883 -- The component type may be private, in which case we install its
884 -- full view to compile the subprogram.
886 -- The component type may be private, in which case we install its
887 -- full view to compile the subprogram. We do not do this if the
888 -- type has a Stream_Convert pragma, which indicates that there are
889 -- special stream-processing operations for that type (for example
890 -- Unbounded_String and its wide varieties).
892 -- We don't install the package either if array type and element
893 -- type come from the same package, and the original array type is
894 -- private, because in this case the underlying type Arr is
895 -- itself a full view, which carries the full view of the component.
897 Scop
:= Scope
(C_Type
);
899 if Is_Private_Type
(C_Type
)
900 and then Present
(Full_View
(C_Type
))
901 and then not In_Open_Scopes
(Scop
)
902 and then Ekind
(Scop
) = E_Package
903 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
905 if Scope
(Arr
) = Scope
(C_Type
)
906 and then Is_Private_Type
(Etype
(Prefix
(N
)))
907 and then Full_View
(Etype
(Prefix
(N
))) = Arr
917 -- If we are within an instance body, then all visibility has been
918 -- established already and there is no need to install the package.
920 if Install
and then not In_Instance_Body
then
922 Install_Visible_Declarations
(Scop
);
923 Install_Private_Declarations
(Scop
);
925 -- The entities in the package are now visible, but the generated
926 -- stream entity must appear in the current scope (usually an
927 -- enclosing stream function) so that itypes all have their proper
935 Insert_Action
(N
, Decl
);
939 -- Remove extra copy of current scope, and package itself
942 End_Package_Scope
(Scop
);
944 end Compile_Stream_Body_In_Scope
;
946 -----------------------------------
947 -- Default_Streaming_Unavailable --
948 -----------------------------------
950 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean is
951 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
953 if Is_Immutably_Limited_Type
(Btyp
)
954 and then not Is_Tagged_Type
(Btyp
)
955 and then not (Ekind
(Btyp
) = E_Record_Type
956 and then Present
(Corresponding_Concurrent_Type
(Btyp
)))
958 pragma Assert
(In_Instance_Body
);
962 end Default_Streaming_Unavailable
;
964 -----------------------------------
965 -- Expand_Access_To_Protected_Op --
966 -----------------------------------
968 procedure Expand_Access_To_Protected_Op
973 -- The value of the attribute_reference is a record containing two
974 -- fields: an access to the protected object, and an access to the
975 -- subprogram itself. The prefix is an identifier or a selected
978 function Has_By_Protected_Procedure_Prefixed_View
return Boolean;
979 -- Determine whether Pref denotes the prefixed class-wide interface
980 -- view of a procedure with synchronization kind By_Protected_Procedure.
982 ----------------------------------------------
983 -- Has_By_Protected_Procedure_Prefixed_View --
984 ----------------------------------------------
986 function Has_By_Protected_Procedure_Prefixed_View
return Boolean is
988 return Nkind
(Pref
) = N_Selected_Component
989 and then Nkind
(Prefix
(Pref
)) in N_Has_Entity
990 and then Present
(Entity
(Prefix
(Pref
)))
991 and then Is_Class_Wide_Type
(Etype
(Entity
(Prefix
(Pref
))))
992 and then (Is_Synchronized_Interface
(Etype
(Entity
(Prefix
(Pref
))))
994 Is_Protected_Interface
(Etype
(Entity
(Prefix
(Pref
)))))
995 and then Is_By_Protected_Procedure
(Entity
(Selector_Name
(Pref
)));
996 end Has_By_Protected_Procedure_Prefixed_View
;
1000 Loc
: constant Source_Ptr
:= Sloc
(N
);
1002 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1003 Sub
: Entity_Id
:= Empty
;
1005 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
1006 Acc
: constant Entity_Id
:=
1007 Etype
(Next_Component
(First_Component
(E_T
)));
1011 -- Start of processing for Expand_Access_To_Protected_Op
1014 -- Within the body of the protected type, the prefix designates a local
1015 -- operation, and the object is the first parameter of the corresponding
1016 -- protected body of the current enclosing operation.
1018 if Is_Entity_Name
(Pref
) then
1019 -- All indirect calls are external calls, so must do locking and
1020 -- barrier reevaluation, even if the 'Access occurs within the
1021 -- protected body. Hence the call to External_Subprogram, as opposed
1022 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
1023 -- that indirect calls from within the same protected body will
1024 -- deadlock, as allowed by RM-9.5.1(8,15,17).
1026 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
1028 -- Don't traverse the scopes when the attribute occurs within an init
1029 -- proc, because we directly use the _init formal of the init proc in
1032 Curr
:= Current_Scope
;
1033 if not Is_Init_Proc
(Curr
) then
1034 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
1036 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
1037 Curr
:= Scope
(Curr
);
1041 -- In case of protected entries the first formal of its Protected_
1042 -- Body_Subprogram is the address of the object.
1044 if Ekind
(Curr
) = E_Entry
then
1048 (Protected_Body_Subprogram
(Curr
)), Loc
);
1050 -- If the current scope is an init proc, then use the address of the
1051 -- _init formal as the object reference.
1053 elsif Is_Init_Proc
(Curr
) then
1055 Make_Attribute_Reference
(Loc
,
1056 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
1057 Attribute_Name
=> Name_Address
);
1059 -- In case of protected subprograms the first formal of its
1060 -- Protected_Body_Subprogram is the object and we get its address.
1064 Make_Attribute_Reference
(Loc
,
1068 (Protected_Body_Subprogram
(Curr
)), Loc
),
1069 Attribute_Name
=> Name_Address
);
1072 elsif Has_By_Protected_Procedure_Prefixed_View
then
1074 Make_Attribute_Reference
(Loc
,
1075 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1076 Attribute_Name
=> Name_Address
);
1078 -- Analyze the object address with expansion disabled. Required
1079 -- because its expansion would displace the pointer to the object,
1080 -- which is not correct at this stage since the object type is a
1081 -- class-wide interface type and we are dispatching a call to a
1082 -- thunk (which would erroneously displace the pointer again).
1084 Expander_Mode_Save_And_Set
(False);
1086 Set_Analyzed
(Obj_Ref
);
1087 Expander_Mode_Restore
;
1089 -- Case where the prefix is not an entity name. Find the
1090 -- version of the protected operation to be called from
1091 -- outside the protected object.
1096 (External_Subprogram
1097 (Entity
(Selector_Name
(Pref
))), Loc
);
1100 Make_Attribute_Reference
(Loc
,
1101 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1102 Attribute_Name
=> Name_Address
);
1105 if Has_By_Protected_Procedure_Prefixed_View
then
1107 Ctrl_Tag
: Node_Id
:= Duplicate_Subexpr
(Prefix
(Pref
));
1108 Prim_Addr
: Node_Id
;
1109 Subp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
1110 Typ
: constant Entity_Id
:=
1111 Etype
(Etype
(Entity
(Prefix
(Pref
))));
1113 -- The target subprogram is a thunk; retrieve its address from
1114 -- its secondary dispatch table slot.
1116 Build_Get_Prim_Op_Address
(Loc
,
1118 Tag_Node
=> Ctrl_Tag
,
1119 Position
=> DT_Position
(Subp
),
1120 New_Node
=> Prim_Addr
);
1122 -- Mark the access to the target subprogram as an access to the
1123 -- dispatch table and perform an unchecked type conversion to such
1124 -- access type. This is required to allow the backend to properly
1125 -- identify and handle the access to the dispatch table slot on
1126 -- targets where the dispatch table contains descriptors (instead
1129 Set_Is_Dispatch_Table_Entity
(Acc
);
1130 Sub_Ref
:= Unchecked_Convert_To
(Acc
, Prim_Addr
);
1134 Make_Aggregate
(Loc
,
1135 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1142 Make_Attribute_Reference
(Loc
,
1144 Attribute_Name
=> Name_Access
);
1146 -- We set the type of the access reference to the already generated
1147 -- access_to_subprogram type, and declare the reference analyzed,
1148 -- to prevent further expansion when the enclosing aggregate is
1151 Set_Etype
(Sub_Ref
, Acc
);
1152 Set_Analyzed
(Sub_Ref
);
1155 Make_Aggregate
(Loc
,
1156 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1158 -- Sub_Ref has been marked as analyzed, but we still need to make
1159 -- sure Sub is correctly frozen.
1161 Freeze_Before
(N
, Entity
(Sub
));
1165 Analyze_And_Resolve
(N
, E_T
);
1167 -- For subsequent analysis, the node must retain its type. The backend
1168 -- will replace it with the equivalent type where needed.
1171 end Expand_Access_To_Protected_Op
;
1173 --------------------------
1174 -- Expand_Fpt_Attribute --
1175 --------------------------
1177 procedure Expand_Fpt_Attribute
1183 Loc
: constant Source_Ptr
:= Sloc
(N
);
1184 Typ
: constant Entity_Id
:= Etype
(N
);
1188 -- The function name is the selected component Attr_xxx.yyy where
1189 -- Attr_xxx is the package name, and yyy is the argument Nam.
1191 -- Note: it would be more usual to have separate RE entries for each
1192 -- of the entities in the Fat packages, but first they have identical
1193 -- names (so we would have to have lots of renaming declarations to
1194 -- meet the normal RE rule of separate names for all runtime entities),
1195 -- and second there would be an awful lot of them.
1198 Make_Selected_Component
(Loc
,
1199 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
1200 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
1202 -- The generated call is given the provided set of parameters, and then
1203 -- wrapped in a conversion which converts the result to the target type.
1207 Make_Function_Call
(Loc
,
1209 Parameter_Associations
=> Args
)));
1211 Analyze_And_Resolve
(N
, Typ
);
1212 end Expand_Fpt_Attribute
;
1214 ----------------------------
1215 -- Expand_Fpt_Attribute_R --
1216 ----------------------------
1218 -- The single argument is converted to its root type to call the
1219 -- appropriate runtime function, with the actual call being built
1220 -- by Expand_Fpt_Attribute
1222 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
1223 E1
: constant Node_Id
:= First
(Expressions
(N
));
1227 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1228 Expand_Fpt_Attribute
1229 (N
, Pkg
, Attribute_Name
(N
),
1230 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
1231 end Expand_Fpt_Attribute_R
;
1233 -----------------------------
1234 -- Expand_Fpt_Attribute_RI --
1235 -----------------------------
1237 -- The first argument is converted to its root type and the second
1238 -- argument is converted to standard long long integer to call the
1239 -- appropriate runtime function, with the actual call being built
1240 -- by Expand_Fpt_Attribute
1242 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
1243 E1
: constant Node_Id
:= First
(Expressions
(N
));
1244 E2
: constant Node_Id
:= Next
(E1
);
1248 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1249 Expand_Fpt_Attribute
1250 (N
, Pkg
, Attribute_Name
(N
),
1252 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1253 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
1254 end Expand_Fpt_Attribute_RI
;
1256 -----------------------------
1257 -- Expand_Fpt_Attribute_RR --
1258 -----------------------------
1260 -- The two arguments are converted to their root types to call the
1261 -- appropriate runtime function, with the actual call being built
1262 -- by Expand_Fpt_Attribute
1264 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
1265 E1
: constant Node_Id
:= First
(Expressions
(N
));
1266 E2
: constant Node_Id
:= Next
(E1
);
1271 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1272 Expand_Fpt_Attribute
1273 (N
, Pkg
, Attribute_Name
(N
),
1275 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1276 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
1277 end Expand_Fpt_Attribute_RR
;
1279 ---------------------------------
1280 -- Expand_Loop_Entry_Attribute --
1281 ---------------------------------
1283 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
1284 procedure Build_Conditional_Block
1287 Loop_Stmt
: Node_Id
;
1288 If_Stmt
: out Node_Id
;
1289 Blk_Stmt
: out Node_Id
);
1290 -- Create a block Blk_Stmt with an empty declarative list and a single
1291 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1292 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1294 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
1295 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1298 -----------------------------
1299 -- Build_Conditional_Block --
1300 -----------------------------
1302 procedure Build_Conditional_Block
1305 Loop_Stmt
: Node_Id
;
1306 If_Stmt
: out Node_Id
;
1307 Blk_Stmt
: out Node_Id
)
1310 -- Do not reanalyze the original loop statement because it is simply
1313 Set_Analyzed
(Loop_Stmt
);
1316 Make_Block_Statement
(Loc
,
1317 Declarations
=> New_List
,
1318 Handled_Statement_Sequence
=>
1319 Make_Handled_Sequence_Of_Statements
(Loc
,
1320 Statements
=> New_List
(Loop_Stmt
)));
1322 if Present
(Cond
) then
1324 Make_If_Statement
(Loc
,
1326 Then_Statements
=> New_List
(Blk_Stmt
));
1330 end Build_Conditional_Block
;
1332 ------------------------
1333 -- Is_Array_Iteration --
1334 ------------------------
1336 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1337 Stmt
: constant Node_Id
:= Original_Node
(N
);
1341 if Nkind
(Stmt
) = N_Loop_Statement
1342 and then Present
(Iteration_Scheme
(Stmt
))
1343 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1345 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1348 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1352 end Is_Array_Iteration
;
1356 Pref
: constant Node_Id
:= Prefix
(N
);
1357 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1358 Exprs
: constant List_Id
:= Expressions
(N
);
1360 Blk
: Node_Id
:= Empty
;
1362 Installed
: Boolean;
1364 Loop_Id
: Entity_Id
;
1365 Loop_Stmt
: Node_Id
;
1366 Result
: Node_Id
:= Empty
;
1368 Temp_Decl
: Node_Id
;
1369 Temp_Id
: Entity_Id
;
1371 -- Start of processing for Expand_Loop_Entry_Attribute
1374 -- Step 1: Find the related loop
1376 -- The loop label variant of attribute 'Loop_Entry already has all the
1377 -- information in its expression.
1379 if Present
(Exprs
) then
1380 Loop_Id
:= Entity
(First
(Exprs
));
1381 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1383 -- Climb the parent chain to find the nearest enclosing loop. Skip
1384 -- all internally generated loops for quantified expressions and for
1385 -- element iterators over multidimensional arrays because the pragma
1386 -- applies to source loop.
1390 while Present
(Loop_Stmt
) loop
1391 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1392 and then Nkind
(Original_Node
(Loop_Stmt
)) = N_Loop_Statement
1393 and then Comes_From_Source
(Original_Node
(Loop_Stmt
))
1398 Loop_Stmt
:= Parent
(Loop_Stmt
);
1401 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1404 Loc
:= Sloc
(Loop_Stmt
);
1406 -- Step 2: Transform the loop
1408 -- The loop has already been transformed during the expansion of a prior
1409 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1411 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1413 -- When the related loop name appears as the argument of attribute
1414 -- Loop_Entry, the corresponding label construct is the generated
1415 -- block statement. This is because the expander reuses the label.
1417 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1418 Decls
:= Declarations
(Loop_Stmt
);
1420 -- In all other cases, the loop must appear in the handled sequence
1421 -- of statements of the generated block.
1425 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1427 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1429 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1432 -- Transform the loop into a conditional block
1435 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1436 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1438 -- Infinite loops are transformed into:
1441 -- Temp1 : constant <type of Pref1> := <Pref1>;
1443 -- TempN : constant <type of PrefN> := <PrefN>;
1446 -- <original source statements with attribute rewrites>
1451 Build_Conditional_Block
(Loc
,
1453 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1459 -- While loops are transformed into:
1461 -- function Fnn return Boolean is
1463 -- <condition actions>
1464 -- return <condition>;
1469 -- Temp1 : constant <type of Pref1> := <Pref1>;
1471 -- TempN : constant <type of PrefN> := <PrefN>;
1474 -- <original source statements with attribute rewrites>
1475 -- exit when not Fnn;
1480 -- Note that loops over iterators and containers are already
1481 -- converted into while loops.
1483 elsif Present
(Condition
(Scheme
)) then
1485 Func_Decl
: Node_Id
;
1486 Func_Id
: Entity_Id
;
1490 Func_Id
:= Make_Temporary
(Loc
, 'F');
1492 -- Wrap the condition of the while loop in a Boolean function.
1493 -- This avoids the duplication of the same code which may lead
1494 -- to gigi issues with respect to multiple declaration of the
1495 -- same entity in the presence of side effects or checks. Note
1496 -- that the condition actions must also be relocated into the
1497 -- wrapping function because they may contain itypes, e.g. in
1498 -- the case of a comparison involving slices.
1501 -- <condition actions>
1502 -- return <condition>;
1504 if Present
(Condition_Actions
(Scheme
)) then
1505 Stmts
:= Condition_Actions
(Scheme
);
1511 Make_Simple_Return_Statement
(Loc
,
1513 New_Copy_Tree
(Condition
(Scheme
),
1514 New_Scope
=> Func_Id
)));
1517 -- function Fnn return Boolean is
1523 Make_Subprogram_Body
(Loc
,
1525 Make_Function_Specification
(Loc
,
1526 Defining_Unit_Name
=> Func_Id
,
1527 Result_Definition
=>
1528 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1529 Declarations
=> Empty_List
,
1530 Handled_Statement_Sequence
=>
1531 Make_Handled_Sequence_Of_Statements
(Loc
,
1532 Statements
=> Stmts
));
1534 -- The function is inserted before the related loop. Make sure
1535 -- to analyze it in the context of the loop's enclosing scope.
1537 Push_Scope
(Scope
(Loop_Id
));
1538 Insert_Action
(Loop_Stmt
, Func_Decl
);
1541 -- The analysis of the condition may have generated entities
1542 -- (such as itypes) that are now used within the function.
1543 -- Adjust their scopes accordingly so that their use appears
1544 -- in their scope of definition.
1550 Ent
:= First_Entity
(Loop_Id
);
1552 while Present
(Ent
) loop
1553 -- Various entities that now occur within the function
1554 -- need to have their scope reset, but not all entities
1555 -- associated with Loop_Id are now inside the function.
1556 -- The function entity itself and loop parameters can
1557 -- be outside the function, and there may be others.
1558 -- It's not clear how the determination of what entity
1559 -- scopes need to be adjusted can be made accurately.
1560 -- Perhaps it will be necessary to traverse the function
1561 -- body to find the exact entities whose scopes need to
1562 -- be reset to the function's Entity_Id. ???
1564 if Ekind
(Ent
) /= E_Loop_Parameter
1565 and then Ent
/= Func_Id
1567 Set_Scope
(Ent
, Func_Id
);
1574 -- Transform the original while loop into an infinite loop
1575 -- where the last statement checks the negated condition. This
1576 -- placement ensures that the condition will not be evaluated
1577 -- twice on the first iteration.
1579 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1583 -- exit when not Fnn;
1585 Append_To
(Statements
(Loop_Stmt
),
1586 Make_Exit_Statement
(Loc
,
1590 Make_Function_Call
(Loc
,
1591 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1593 Build_Conditional_Block
(Loc
,
1595 Make_Function_Call
(Loc
,
1596 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1597 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1602 -- Ada 2012 iteration over an array is transformed into:
1604 -- if <Array_Nam>'Length (1) > 0
1605 -- and then <Array_Nam>'Length (N) > 0
1608 -- Temp1 : constant <type of Pref1> := <Pref1>;
1610 -- TempN : constant <type of PrefN> := <PrefN>;
1612 -- for X in ... loop -- multiple loops depending on dims
1613 -- <original source statements with attribute rewrites>
1618 elsif Is_Array_Iteration
(Loop_Stmt
) then
1620 Array_Nam
: constant Entity_Id
:=
1621 Entity
(Name
(Iterator_Specification
1622 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1623 Num_Dims
: constant Pos
:=
1624 Number_Dimensions
(Etype
(Array_Nam
));
1625 Cond
: Node_Id
:= Empty
;
1629 -- Generate a check which determines whether all dimensions of
1630 -- the array are non-null.
1632 for Dim
in 1 .. Num_Dims
loop
1636 Make_Attribute_Reference
(Loc
,
1637 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1638 Attribute_Name
=> Name_Length
,
1639 Expressions
=> New_List
(
1640 Make_Integer_Literal
(Loc
, Dim
))),
1642 Make_Integer_Literal
(Loc
, 0));
1650 Right_Opnd
=> Check
);
1654 Build_Conditional_Block
(Loc
,
1656 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1661 -- For loops are transformed into:
1663 -- if <Low> <= <High> then
1665 -- Temp1 : constant <type of Pref1> := <Pref1>;
1667 -- TempN : constant <type of PrefN> := <PrefN>;
1669 -- for <Def_Id> in <Low> .. <High> loop
1670 -- <original source statements with attribute rewrites>
1675 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1677 Loop_Spec
: constant Node_Id
:=
1678 Loop_Parameter_Specification
(Scheme
);
1683 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1685 -- When the loop iterates over a subtype indication with a
1686 -- range, use the low and high bounds of the subtype itself.
1688 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1689 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1692 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1699 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1700 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1702 Build_Conditional_Block
(Loc
,
1704 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1710 Decls
:= Declarations
(Blk
);
1713 -- Step 3: Create a constant to capture the value of the prefix at the
1714 -- entry point into the loop.
1716 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1718 -- Preserve the tag of the prefix by offering a specific view of the
1719 -- class-wide version of the prefix.
1721 if Is_Tagged_Type
(Base_Typ
) then
1722 Tagged_Case
: declare
1723 CW_Temp
: Entity_Id
;
1728 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1730 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1731 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1734 Make_Object_Declaration
(Loc
,
1735 Defining_Identifier
=> CW_Temp
,
1736 Constant_Present
=> True,
1737 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1739 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1740 Append_To
(Decls
, Aux_Decl
);
1743 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1746 Make_Object_Renaming_Declaration
(Loc
,
1747 Defining_Identifier
=> Temp_Id
,
1748 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1750 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1751 Append_To
(Decls
, Temp_Decl
);
1757 Untagged_Case
: declare
1758 Temp_Expr
: Node_Id
;
1763 -- Generate a nominal type for the constant when the prefix is of
1764 -- a constrained type. This is achieved by setting the Etype of
1765 -- the relocated prefix to its base type. Since the prefix is now
1766 -- the initialization expression of the constant, its freezing
1767 -- will produce a proper nominal type.
1769 Temp_Expr
:= Relocate_Node
(Pref
);
1770 Set_Etype
(Temp_Expr
, Base_Typ
);
1773 -- Temp : constant Base_Typ := Pref;
1776 Make_Object_Declaration
(Loc
,
1777 Defining_Identifier
=> Temp_Id
,
1778 Constant_Present
=> True,
1779 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1780 Expression
=> Temp_Expr
);
1781 Append_To
(Decls
, Temp_Decl
);
1785 -- Step 4: Analyze all bits
1787 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1789 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1790 -- associated loop, ensure the proper visibility for analysis.
1792 if not Installed
then
1793 Push_Scope
(Scope
(Loop_Id
));
1796 -- Analyze constant declaration with simple value propagation disabled,
1797 -- because the values at the loop entry might be different than the
1798 -- values at the occurrence of Loop_Entry attribute.
1801 Save_Debug_Flag_MM
: constant Boolean := Debug_Flag_MM
;
1803 Debug_Flag_MM
:= True;
1805 if Present
(Aux_Decl
) then
1809 Analyze
(Temp_Decl
);
1811 Debug_Flag_MM
:= Save_Debug_Flag_MM
;
1814 -- If the conditional block has just been created, then analyze it;
1815 -- otherwise it was analyzed when a previous 'Loop_Entry was expanded.
1817 if Present
(Result
) then
1818 Rewrite
(Loop_Stmt
, Result
);
1819 Analyze
(Loop_Stmt
);
1822 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1825 if not Installed
then
1828 end Expand_Loop_Entry_Attribute
;
1830 ------------------------------
1831 -- Expand_Min_Max_Attribute --
1832 ------------------------------
1834 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1836 -- Min and Max are handled by the back end (except that static cases
1837 -- have already been evaluated during semantic processing, although the
1838 -- back end should not count on this). The one bit of special processing
1839 -- required in the normal case is that these two attributes typically
1840 -- generate conditionals in the code, so check the relevant restriction.
1842 Check_Restriction
(No_Implicit_Conditionals
, N
);
1843 end Expand_Min_Max_Attribute
;
1845 ----------------------------------
1846 -- Expand_N_Attribute_Reference --
1847 ----------------------------------
1849 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1850 Loc
: constant Source_Ptr
:= Sloc
(N
);
1851 Pref
: constant Node_Id
:= Prefix
(N
);
1852 Exprs
: constant List_Id
:= Expressions
(N
);
1854 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
;
1855 -- Return a small integer type appropriate for the enumeration type
1857 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
);
1858 -- Rewrites an attribute for Read, Write, Output, or Put_Image with a
1859 -- call to the appropriate TSS procedure. Pname is the entity for the
1860 -- procedure to call.
1862 ----------------------
1863 -- Get_Integer_Type --
1864 ----------------------
1866 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
is
1867 Siz
: constant Uint
:= Esize
(Base_Type
(Typ
));
1870 -- We need to accommodate invalid values of the base type since we
1871 -- accept them for Enum_Rep and Pos, so we reason on the Esize.
1873 return Small_Integer_Type_For
(Siz
, Uns
=> Is_Unsigned_Type
(Typ
));
1874 end Get_Integer_Type
;
1876 ---------------------------------
1877 -- Rewrite_Attribute_Proc_Call --
1878 ---------------------------------
1880 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
) is
1881 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1882 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1883 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1884 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1885 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1888 -- The expansion depends on Item, the second actual, which is
1889 -- the object being streamed in or out.
1891 -- If the item is a component of a packed array type, and
1892 -- a conversion is needed on exit, we introduce a temporary to
1893 -- hold the value, because otherwise the packed reference will
1894 -- not be properly expanded.
1896 if Nkind
(Item
) = N_Indexed_Component
1897 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1898 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1902 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1908 Make_Object_Declaration
(Loc
,
1909 Defining_Identifier
=> Temp
,
1910 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1911 Set_Etype
(Temp
, Formal_Typ
);
1914 Make_Assignment_Statement
(Loc
,
1915 Name
=> New_Copy_Tree
(Item
),
1917 Unchecked_Convert_To
1918 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1920 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1924 Make_Procedure_Call_Statement
(Loc
,
1925 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1926 Parameter_Associations
=> Exprs
),
1929 Rewrite
(N
, Make_Null_Statement
(Loc
));
1934 -- For the class-wide dispatching cases, and for cases in which
1935 -- the base type of the second argument matches the base type of
1936 -- the corresponding formal parameter (that is to say the stream
1937 -- operation is not inherited), we are all set, and can use the
1938 -- argument unchanged.
1940 if not Is_Class_Wide_Type
(Entity
(Pref
))
1941 and then not Is_Class_Wide_Type
(Etype
(Item
))
1942 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1944 -- Perform a view conversion when either the argument or the
1945 -- formal parameter are of a private type.
1947 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1948 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1951 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1953 -- Otherwise perform a regular type conversion to ensure that all
1954 -- relevant checks are installed.
1957 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1960 -- For untagged derived types set Assignment_OK, to prevent
1961 -- copies from being created when the unchecked conversion
1962 -- is expanded (which would happen in Remove_Side_Effects
1963 -- if Expand_N_Unchecked_Conversion were allowed to call
1964 -- Force_Evaluation). The copy could violate Ada semantics in
1965 -- cases such as an actual that is an out parameter. Note that
1966 -- this approach is also used in exp_ch7 for calls to controlled
1967 -- type operations to prevent problems with actuals wrapped in
1968 -- unchecked conversions.
1970 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1971 Set_Assignment_OK
(Item
);
1975 -- The stream operation to call might be a renaming created by an
1976 -- attribute definition clause, and might not be frozen yet. Ensure
1977 -- that it has the necessary extra formals.
1979 if not Is_Frozen
(Pname
) then
1980 Create_Extra_Formals
(Pname
);
1983 -- And now rewrite the call
1986 Make_Procedure_Call_Statement
(Loc
,
1987 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1988 Parameter_Associations
=> Exprs
));
1991 end Rewrite_Attribute_Proc_Call
;
1993 Typ
: constant Entity_Id
:= Etype
(N
);
1994 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1995 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1996 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1998 -- Start of processing for Expand_N_Attribute_Reference
2001 -- Do required validity checking, if enabled. Do not apply check to
2002 -- output parameters of an Asm instruction, since the value of this
2003 -- is not set till after the attribute has been elaborated, and do
2004 -- not apply the check to the arguments of a 'Read or 'Input attribute
2005 -- reference since the scalar argument is an OUT scalar.
2007 if Validity_Checks_On
and then Validity_Check_Operands
2008 and then Id
/= Attribute_Asm_Output
2009 and then Id
/= Attribute_Read
2010 and then Id
/= Attribute_Input
2015 Expr
:= First
(Expressions
(N
));
2016 while Present
(Expr
) loop
2017 Ensure_Valid
(Expr
);
2023 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
2024 -- place function, then a temporary return object needs to be created
2025 -- and access to it must be passed to the function.
2027 if Is_Build_In_Place_Function_Call
(Pref
) then
2029 -- If attribute is 'Old, the context is a postcondition, and
2030 -- the temporary must go in the corresponding subprogram, not
2031 -- the postcondition function or any created blocks, as when
2032 -- the attribute appears in a quantified expression. This is
2033 -- handled below in the expansion of the attribute.
2035 if Attribute_Name
(Parent
(Pref
)) = Name_Old
then
2038 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
2041 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
2042 -- containing build-in-place function calls whose returned object covers
2045 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
2046 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
2049 -- If prefix is a protected type name, this is a reference to the
2050 -- current instance of the type. For a component definition, nothing
2051 -- to do (expansion will occur in the init proc). In other contexts,
2052 -- rewrite into reference to current instance.
2054 if Is_Protected_Self_Reference
(Pref
)
2056 (Nkind
(Parent
(N
)) in N_Index_Or_Discriminant_Constraint
2057 | N_Discriminant_Association
2058 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
2059 N_Component_Definition
)
2061 -- No action needed for these attributes since the current instance
2062 -- will be rewritten to be the name of the _object parameter
2063 -- associated with the enclosing protected subprogram (see below).
2065 and then Id
/= Attribute_Access
2066 and then Id
/= Attribute_Unchecked_Access
2067 and then Id
/= Attribute_Unrestricted_Access
2069 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
2073 -- Remaining processing depends on specific attribute
2075 -- Note: individual sections of the following case statement are
2076 -- allowed to assume there is no code after the case statement, and
2077 -- are legitimately allowed to execute return statements if they have
2078 -- nothing more to do.
2082 -- Attributes related to Ada 2012 iterators
2084 when Attribute_Constant_Indexing
2085 | Attribute_Default_Iterator
2086 | Attribute_Implicit_Dereference
2087 | Attribute_Iterable
2088 | Attribute_Iterator_Element
2089 | Attribute_Variable_Indexing
2093 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2094 -- were already rejected by the parser. Thus they shouldn't appear here.
2096 when Internal_Attribute_Id
=>
2097 raise Program_Error
;
2103 when Attribute_Access
2104 | Attribute_Unchecked_Access
2105 | Attribute_Unrestricted_Access
2107 Access_Cases
: declare
2108 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
2109 Btyp_DDT
: Entity_Id
;
2111 procedure Add_Implicit_Interface_Type_Conversion
;
2112 -- Ada 2005 (AI-251): The designated type is an interface type;
2113 -- add an implicit type conversion to force the displacement of
2114 -- the pointer to reference the secondary dispatch table.
2116 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
2117 -- If N denotes a compound name (selected component, indexed
2118 -- component, or slice), returns the name of the outermost such
2119 -- enclosing object. Otherwise returns N. If the object is a
2120 -- renaming, then the renamed object is returned.
2122 --------------------------------------------
2123 -- Add_Implicit_Interface_Type_Conversion --
2124 --------------------------------------------
2126 procedure Add_Implicit_Interface_Type_Conversion
is
2128 pragma Assert
(Is_Interface
(Btyp_DDT
));
2130 -- Handle cases were no action is required.
2132 if not Comes_From_Source
(N
)
2133 and then not Comes_From_Source
(Ref_Object
)
2134 and then (Nkind
(Ref_Object
) not in N_Has_Chars
2135 or else Chars
(Ref_Object
) /= Name_uInit
)
2142 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2144 -- No implicit conversion required if types match, or if
2145 -- the prefix is the class_wide_type of the interface. In
2146 -- either case passing an object of the interface type has
2147 -- already set the pointer correctly.
2149 if Btyp_DDT
= Etype
(Ref_Object
)
2151 (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2153 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2158 Rewrite
(Prefix
(N
),
2159 Convert_To
(Btyp_DDT
,
2160 New_Copy_Tree
(Prefix
(N
))));
2162 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2165 -- When the object is an explicit dereference, convert the
2166 -- dereference's prefix.
2170 Obj_DDT
: constant Entity_Id
:=
2172 (Directly_Designated_Type
2173 (Etype
(Prefix
(Ref_Object
))));
2175 -- No implicit conversion required if designated types
2178 if Obj_DDT
/= Btyp_DDT
2179 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2180 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2184 New_Copy_Tree
(Prefix
(Ref_Object
))));
2185 Analyze_And_Resolve
(N
, Typ
);
2189 end Add_Implicit_Interface_Type_Conversion
;
2191 ----------------------
2192 -- Enclosing_Object --
2193 ----------------------
2195 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
2200 while Nkind
(Obj_Name
) in N_Selected_Component
2201 | N_Indexed_Component
2204 Obj_Name
:= Prefix
(Obj_Name
);
2207 return Get_Referenced_Object
(Obj_Name
);
2208 end Enclosing_Object
;
2210 -- Local declarations
2212 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
2214 -- Start of processing for Access_Cases
2217 Btyp_DDT
:= Designated_Type
(Btyp
);
2219 -- Handle designated types that come from the limited view
2221 if From_Limited_With
(Btyp_DDT
)
2222 and then Has_Non_Limited_View
(Btyp_DDT
)
2224 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
2227 -- In order to improve the text of error messages, the designated
2228 -- type of access-to-subprogram itypes is set by the semantics as
2229 -- the associated subprogram entity (see sem_attr). Now we replace
2230 -- such node with the proper E_Subprogram_Type itype.
2232 if Id
= Attribute_Unrestricted_Access
2233 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
2235 -- The following conditions ensure that this special management
2236 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2237 -- At this stage other cases in which the designated type is
2238 -- still a subprogram (instead of an E_Subprogram_Type) are
2239 -- wrong because the semantics must have overridden the type of
2240 -- the node with the type imposed by the context.
2242 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
2243 and then Is_RTE
(Etype
(Parent
(N
)), RE_Prim_Ptr
)
2245 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
2249 Subp
: constant Entity_Id
:=
2250 Directly_Designated_Type
(Typ
);
2252 Extra
: Entity_Id
:= Empty
;
2253 New_Formal
: Entity_Id
;
2254 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
2255 Subp_Typ
: Entity_Id
;
2258 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
2259 Copy_Strub_Mode
(Subp_Typ
, Subp
);
2260 Set_Etype
(Subp_Typ
, Etype
(Subp
));
2261 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
2263 if Present
(Old_Formal
) then
2264 New_Formal
:= New_Copy
(Old_Formal
);
2265 Set_First_Entity
(Subp_Typ
, New_Formal
);
2268 Set_Scope
(New_Formal
, Subp_Typ
);
2269 Etyp
:= Etype
(New_Formal
);
2271 -- Handle itypes. There is no need to duplicate
2272 -- here the itypes associated with record types
2273 -- (i.e the implicit full view of private types).
2276 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
2278 Extra
:= New_Copy
(Etyp
);
2279 Set_Parent
(Extra
, New_Formal
);
2280 Set_Etype
(New_Formal
, Extra
);
2281 Set_Scope
(Extra
, Subp_Typ
);
2284 Extra
:= New_Formal
;
2285 Next_Formal
(Old_Formal
);
2286 exit when No
(Old_Formal
);
2288 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
2289 Next_Entity
(New_Formal
);
2292 Unlink_Next_Entity
(New_Formal
);
2293 Set_Last_Entity
(Subp_Typ
, Extra
);
2296 -- Now that the explicit formals have been duplicated,
2297 -- any extra formals needed by the subprogram must be
2300 if Present
(Extra
) then
2301 Set_Extra_Formal
(Extra
, Empty
);
2304 Create_Extra_Formals
(Subp_Typ
);
2305 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
2310 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
2311 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
2313 -- If prefix is a subprogram that has class-wide preconditions and
2314 -- an indirect-call wrapper (ICW) of such subprogram is available
2315 -- then replace the prefix by the ICW.
2317 elsif Is_Access_Subprogram_Type
(Btyp
)
2318 and then Is_Entity_Name
(Pref
)
2319 and then Present
(Class_Preconditions
(Entity
(Pref
)))
2320 and then Present
(Indirect_Call_Wrapper
(Entity
(Pref
)))
2324 (Indirect_Call_Wrapper
(Entity
(Pref
)), Loc
));
2325 Analyze_And_Resolve
(N
, Typ
);
2327 -- If prefix is a type name, this is a reference to the current
2328 -- instance of the type, within its initialization procedure.
2330 elsif Is_Entity_Name
(Pref
)
2331 and then Is_Type
(Entity
(Pref
))
2338 -- If the current instance name denotes a task type, then
2339 -- the access attribute is rewritten to be the name of the
2340 -- "_task" parameter associated with the task type's task
2341 -- procedure. An unchecked conversion is applied to ensure
2342 -- a type match in cases of expander-generated calls (e.g.
2345 if Is_Task_Type
(Entity
(Pref
)) then
2347 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
2348 while Present
(Formal
) loop
2349 exit when Chars
(Formal
) = Name_uTask
;
2350 Next_Entity
(Formal
);
2353 pragma Assert
(Present
(Formal
));
2356 Unchecked_Convert_To
(Typ
,
2357 New_Occurrence_Of
(Formal
, Loc
)));
2360 elsif Is_Protected_Type
(Entity
(Pref
)) then
2362 -- No action needed for current instance located in a
2363 -- component definition (expansion will occur in the
2366 if Is_Protected_Type
(Current_Scope
) then
2369 -- If the current instance reference is located in a
2370 -- protected subprogram or entry then rewrite the access
2371 -- attribute to be the name of the "_object" parameter.
2372 -- An unchecked conversion is applied to ensure a type
2373 -- match in cases of expander-generated calls (e.g. init
2376 -- The code may be nested in a block, so find enclosing
2377 -- scope that is a protected operation.
2384 Subp
:= Current_Scope
;
2385 while Ekind
(Subp
) in E_Loop | E_Block
loop
2386 Subp
:= Scope
(Subp
);
2391 (Protected_Body_Subprogram
(Subp
));
2393 -- For a protected subprogram the _Object parameter
2394 -- is the protected record, so we create an access
2395 -- to it. The _Object parameter of an entry is an
2398 if Ekind
(Subp
) = E_Entry
then
2400 Unchecked_Convert_To
(Typ
,
2401 New_Occurrence_Of
(Formal
, Loc
)));
2406 Unchecked_Convert_To
(Typ
,
2407 Make_Attribute_Reference
(Loc
,
2408 Attribute_Name
=> Name_Unrestricted_Access
,
2410 New_Occurrence_Of
(Formal
, Loc
))));
2411 Analyze_And_Resolve
(N
);
2416 -- The expression must appear in a default expression,
2417 -- (which in the initialization procedure is the right-hand
2418 -- side of an assignment), and not in a discriminant
2423 while Present
(Par
) loop
2424 exit when Nkind
(Par
) = N_Assignment_Statement
;
2426 if Nkind
(Par
) = N_Component_Declaration
then
2430 Par
:= Parent
(Par
);
2433 if Present
(Par
) then
2435 Make_Attribute_Reference
(Loc
,
2436 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2437 Attribute_Name
=> Attribute_Name
(N
)));
2439 Analyze_And_Resolve
(N
, Typ
);
2444 -- If the prefix of an Access attribute is a dereference of an
2445 -- access parameter (or a renaming of such a dereference, or a
2446 -- subcomponent of such a dereference) and the context is a
2447 -- general access type (including the type of an object or
2448 -- component with an access_definition, but not the anonymous
2449 -- type of an access parameter or access discriminant), then
2450 -- apply an accessibility check to the access parameter. We used
2451 -- to rewrite the access parameter as a type conversion, but that
2452 -- could only be done if the immediate prefix of the Access
2453 -- attribute was the dereference, and didn't handle cases where
2454 -- the attribute is applied to a subcomponent of the dereference,
2455 -- since there's generally no available, appropriate access type
2456 -- to convert to in that case. The attribute is passed as the
2457 -- point to insert the check, because the access parameter may
2458 -- come from a renaming, possibly in a different scope, and the
2459 -- check must be associated with the attribute itself.
2461 elsif Id
= Attribute_Access
2462 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2463 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2464 and then (Ekind
(Btyp
) = E_General_Access_Type
2465 or else Is_Local_Anonymous_Access
(Btyp
))
2466 and then Is_Formal
(Entity
(Prefix
(Enc_Object
)))
2467 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2468 = E_Anonymous_Access_Type
2469 and then Present
(Extra_Accessibility
2470 (Entity
(Prefix
(Enc_Object
))))
2471 and then not No_Dynamic_Accessibility_Checks_Enabled
(Enc_Object
)
2473 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2475 -- Ada 2005 (AI-251): If the designated type is an interface we
2476 -- add an implicit conversion to force the displacement of the
2477 -- pointer to reference the secondary dispatch table.
2479 if Is_Interface
(Btyp_DDT
) then
2480 Add_Implicit_Interface_Type_Conversion
;
2483 -- Ada 2005 (AI-251): If the designated type is an interface we
2484 -- add an implicit conversion to force the displacement of the
2485 -- pointer to reference the secondary dispatch table.
2487 elsif Is_Interface
(Btyp_DDT
) then
2488 Add_Implicit_Interface_Type_Conversion
;
2496 -- Transforms 'Adjacent into a call to the floating-point attribute
2497 -- function Adjacent in Fat_xxx (where xxx is the root type)
2499 when Attribute_Adjacent
=>
2500 Expand_Fpt_Attribute_RR
(N
);
2506 when Attribute_Address
=> Address
: declare
2507 Task_Proc
: Entity_Id
;
2509 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean;
2510 -- Returns True if N is being used to initialize a component of
2511 -- an activation record object where the component corresponds to
2512 -- the object denoted by the prefix of the attribute N.
2514 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean is
2516 return Present
(Parent
(N
))
2517 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2518 and then Is_Entity_Name
(Pref
)
2519 and then Present
(Activation_Record_Component
(Entity
(Pref
)))
2520 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2521 and then Entity
(Selector_Name
(Name
(Parent
(N
)))) =
2522 Activation_Record_Component
(Entity
(Pref
));
2523 end Is_Unnested_Component_Init
;
2525 -- Start of processing for Address
2528 -- If the prefix is a task or a task type, the useful address is that
2529 -- of the procedure for the task body, i.e. the actual program unit.
2530 -- We replace the original entity with that of the procedure.
2532 if Is_Entity_Name
(Pref
)
2533 and then Is_Task_Type
(Entity
(Pref
))
2535 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2537 while Present
(Task_Proc
) loop
2538 exit when Ekind
(Task_Proc
) = E_Procedure
2539 and then Etype
(First_Formal
(Task_Proc
)) =
2540 Corresponding_Record_Type
(Ptyp
);
2541 Next_Entity
(Task_Proc
);
2544 if Present
(Task_Proc
) then
2545 Set_Entity
(Pref
, Task_Proc
);
2546 Set_Etype
(Pref
, Etype
(Task_Proc
));
2549 -- Similarly, the address of a protected operation is the address
2550 -- of the corresponding protected body, regardless of the protected
2551 -- object from which it is selected.
2553 elsif Nkind
(Pref
) = N_Selected_Component
2554 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2555 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2559 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2561 elsif Nkind
(Pref
) = N_Explicit_Dereference
2562 and then Ekind
(Ptyp
) = E_Subprogram_Type
2563 and then Convention
(Ptyp
) = Convention_Protected
2565 -- The prefix is be a dereference of an access_to_protected_
2566 -- subprogram. The desired address is the second component of
2567 -- the record that represents the access.
2570 Addr
: constant Entity_Id
:= Etype
(N
);
2571 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2572 T
: constant Entity_Id
:=
2573 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2577 Unchecked_Convert_To
(Addr
,
2578 Make_Selected_Component
(Loc
,
2579 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2580 Selector_Name
=> New_Occurrence_Of
(
2581 Next_Entity
(First_Entity
(T
)), Loc
))));
2583 Analyze_And_Resolve
(N
, Addr
);
2586 -- 'Address is an actual parameter of the call to the implicit
2587 -- subprogram To_Pointer instantiated with a class-wide interface
2588 -- type; its expansion requires adding an implicit type conversion
2589 -- to force displacement of the "this" pointer.
2591 elsif Tagged_Type_Expansion
2592 and then Nkind
(Parent
(N
)) = N_Function_Call
2593 and then Nkind
(Name
(Parent
(N
))) in N_Has_Entity
2594 and then Is_Intrinsic_Subprogram
(Entity
(Name
(Parent
(N
))))
2595 and then Chars
(Entity
(Name
(Parent
(N
)))) = Name_To_Pointer
2596 and then Is_Interface
(Designated_Type
(Etype
(Parent
(N
))))
2597 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(Parent
(N
))))
2600 Iface_Typ
: constant Entity_Id
:=
2601 Designated_Type
(Etype
(Parent
(N
)));
2603 Rewrite
(Pref
, Convert_To
(Iface_Typ
, Relocate_Node
(Pref
)));
2604 Analyze_And_Resolve
(Pref
, Iface_Typ
);
2608 -- Ada 2005 (AI-251): Class-wide interface objects are always
2609 -- "displaced" to reference the tag associated with the interface
2610 -- type. In order to obtain the real address of such objects we
2611 -- generate a call to a run-time subprogram that returns the base
2612 -- address of the object. This call is not generated in cases where
2613 -- the attribute is being used to initialize a component of an
2614 -- activation record object where the component corresponds to
2615 -- prefix of the attribute (for back ends that require "unnesting"
2616 -- of nested subprograms), since the address needs to be assigned
2617 -- as-is to such components.
2619 elsif Tagged_Type_Expansion
2620 and then Is_Class_Wide_Type
(Ptyp
)
2621 and then Is_Interface
(Underlying_Type
(Ptyp
))
2622 and then not (Nkind
(Pref
) in N_Has_Entity
2623 and then Is_Subprogram
(Entity
(Pref
)))
2624 and then not Is_Unnested_Component_Init
(N
)
2627 Make_Function_Call
(Loc
,
2628 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2629 Parameter_Associations
=> New_List
(Relocate_Node
(N
))));
2634 -- Deal with packed array reference, other cases are handled by
2637 if Involves_Packed_Array_Reference
(Pref
) then
2638 Expand_Packed_Address_Reference
(N
);
2646 when Attribute_Alignment
=> Alignment
: declare
2650 -- For class-wide types, X'Class'Alignment is transformed into a
2651 -- direct reference to the Alignment of the class type, so that the
2652 -- back end does not have to deal with the X'Class'Alignment
2655 if Is_Entity_Name
(Pref
)
2656 and then Is_Class_Wide_Type
(Entity
(Pref
))
2658 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2661 -- For x'Alignment applied to an object of a class wide type,
2662 -- transform X'Alignment into a call to the predefined primitive
2663 -- operation _Alignment applied to X.
2665 elsif Is_Class_Wide_Type
(Ptyp
) then
2667 Make_Attribute_Reference
(Loc
,
2669 Attribute_Name
=> Name_Tag
);
2671 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2673 -- Case where the context is an unchecked conversion to a specific
2674 -- integer type. We directly convert from the alignment's type.
2676 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
then
2677 Rewrite
(N
, New_Node
);
2678 Analyze_And_Resolve
(N
);
2681 -- Case where the context is a specific integer type with which
2682 -- the original attribute was compatible. But the alignment has a
2683 -- specific type in a-tags.ads (Standard.Natural) so, in order to
2684 -- preserve type compatibility, we must convert explicitly.
2686 elsif Typ
/= Standard_Natural
then
2687 New_Node
:= Convert_To
(Typ
, New_Node
);
2690 Rewrite
(N
, New_Node
);
2691 Analyze_And_Resolve
(N
, Typ
);
2694 -- For all other cases, we just have to deal with the case of
2695 -- the fact that the result can be universal.
2698 Apply_Universal_Integer_Attribute_Checks
(N
);
2702 ---------------------------
2703 -- Asm_Input, Asm_Output --
2704 ---------------------------
2706 -- The Asm_Input and Asm_Output attributes are not expanded at this
2707 -- stage, but will be eliminated in the expansion of the Asm call,
2708 -- see Exp_Intr for details. So the back end will never see them.
2710 when Attribute_Asm_Input
2711 | Attribute_Asm_Output
2719 -- We compute this if a packed array reference was present, otherwise we
2720 -- leave the computation up to the back end.
2722 when Attribute_Bit
=>
2723 if Involves_Packed_Array_Reference
(Pref
) then
2724 Expand_Packed_Bit_Reference
(N
);
2726 Apply_Universal_Integer_Attribute_Checks
(N
);
2733 -- We leave the computation up to the back end, since we don't know what
2734 -- layout will be chosen if no component clause was specified.
2736 when Attribute_Bit_Position
=>
2737 Apply_Universal_Integer_Attribute_Checks
(N
);
2743 -- A reference to P'Body_Version or P'Version is expanded to
2746 -- pragma Import (C, Vnn, "uuuuT");
2748 -- Get_Version_String (Vnn)
2750 -- where uuuu is the unit name (dots replaced by double underscore)
2751 -- and T is B for the cases of Body_Version, or Version applied to a
2752 -- subprogram acting as its own spec, and S for Version applied to a
2753 -- subprogram spec or package. This sequence of code references the
2754 -- unsigned constant created in the main program by the binder.
2756 -- A special exception occurs for Standard, where the string returned
2757 -- is a copy of the library string in gnatvsn.ads.
2759 when Attribute_Body_Version
2763 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2768 -- If not library unit, get to containing library unit
2770 Pent
:= Entity
(Pref
);
2771 while Pent
/= Standard_Standard
2772 and then Scope
(Pent
) /= Standard_Standard
2773 and then not Is_Child_Unit
(Pent
)
2775 Pent
:= Scope
(Pent
);
2778 -- Special case Standard and Standard.ASCII
2780 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2782 Make_String_Literal
(Loc
,
2783 Strval
=> Verbose_Library_Version
));
2788 -- Build required string constant
2790 Get_Name_String
(Get_Unit_Name
(Pent
));
2793 for J
in 1 .. Name_Len
- 2 loop
2794 if Name_Buffer
(J
) = '.' then
2795 Store_String_Chars
("__");
2797 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2801 -- Case of subprogram acting as its own spec, always use body
2803 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2804 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2806 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2808 Store_String_Chars
("B");
2810 -- Case of no body present, always use spec
2812 elsif not Unit_Requires_Body
(Pent
) then
2813 Store_String_Chars
("S");
2815 -- Otherwise use B for Body_Version, S for spec
2817 elsif Id
= Attribute_Body_Version
then
2818 Store_String_Chars
("B");
2820 Store_String_Chars
("S");
2824 Lib
.Version_Referenced
(S
);
2826 -- Insert the object declaration
2828 Insert_Actions
(N
, New_List
(
2829 Make_Object_Declaration
(Loc
,
2830 Defining_Identifier
=> E
,
2831 Object_Definition
=>
2832 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2834 -- Set entity as imported with correct external name
2836 Set_Is_Imported
(E
);
2837 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2839 -- Set entity as internal to ensure proper Sprint output of its
2840 -- implicit importation.
2842 Set_Is_Internal
(E
);
2844 -- And now rewrite original reference
2847 Make_Function_Call
(Loc
,
2849 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2850 Parameter_Associations
=> New_List
(
2851 New_Occurrence_Of
(E
, Loc
))));
2854 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2861 -- Transforms 'Ceiling into a call to the floating-point attribute
2862 -- function Ceiling in Fat_xxx (where xxx is the root type)
2864 when Attribute_Ceiling
=>
2865 Expand_Fpt_Attribute_R
(N
);
2871 -- Transforms 'Callable attribute into a call to the Callable function
2873 when Attribute_Callable
=>
2875 -- We have an object of a task interface class-wide type as a prefix
2876 -- to Callable. Generate:
2877 -- callable (Task_Id (Pref._disp_get_task_id));
2879 if Ada_Version
>= Ada_2005
2880 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2881 and then Is_Interface
(Ptyp
)
2882 and then Is_Task_Interface
(Ptyp
)
2885 Make_Function_Call
(Loc
,
2887 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2888 Parameter_Associations
=> New_List
(
2889 Unchecked_Convert_To
2890 (RTE
(RO_ST_Task_Id
),
2891 Build_Disp_Get_Task_Id_Call
(Pref
)))));
2894 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2897 Analyze_And_Resolve
(N
, Standard_Boolean
);
2903 -- Transforms 'Caller attribute into a call to either the
2904 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2906 when Attribute_Caller
=> Caller
: declare
2907 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2908 Ent
: constant Entity_Id
:= Entity
(Pref
);
2909 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2910 Nest_Depth
: Nat
:= 0;
2917 if Is_Protected_Type
(Conctype
) then
2918 case Corresponding_Runtime_Package
(Conctype
) is
2919 when System_Tasking_Protected_Objects_Entries
=>
2922 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2924 when System_Tasking_Protected_Objects_Single_Entry
=>
2927 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2930 raise Program_Error
;
2934 Unchecked_Convert_To
(Id_Kind
,
2935 Make_Function_Call
(Loc
,
2937 Parameter_Associations
=> New_List
(
2939 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2944 -- Determine the nesting depth of the E'Caller attribute, that
2945 -- is, how many accept statements are nested within the accept
2946 -- statement for E at the point of E'Caller. The runtime uses
2947 -- this depth to find the specified entry call.
2949 for J
in reverse 0 .. Scope_Stack
.Last
loop
2950 S
:= Scope_Stack
.Table
(J
).Entity
;
2952 -- We should not reach the scope of the entry, as it should
2953 -- already have been checked in Sem_Attr that this attribute
2954 -- reference is within a matching accept statement.
2956 pragma Assert
(S
/= Conctype
);
2961 elsif Is_Entry
(S
) then
2962 Nest_Depth
:= Nest_Depth
+ 1;
2967 Unchecked_Convert_To
(Id_Kind
,
2968 Make_Function_Call
(Loc
,
2970 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2971 Parameter_Associations
=> New_List
(
2972 Make_Integer_Literal
(Loc
,
2973 Intval
=> Nest_Depth
)))));
2976 Analyze_And_Resolve
(N
, Id_Kind
);
2979 --------------------
2980 -- Component_Size --
2981 --------------------
2983 -- Component_Size is handled by the back end
2985 when Attribute_Component_Size
=>
2986 Apply_Universal_Integer_Attribute_Checks
(N
);
2992 -- Transforms 'Compose into a call to the floating-point attribute
2993 -- function Compose in Fat_xxx (where xxx is the root type)
2995 -- Note: we strictly should have special code here to deal with the
2996 -- case of absurdly negative arguments (less than Integer'First)
2997 -- which will return a (signed) zero value, but it hardly seems
2998 -- worth the effort. Absurdly large positive arguments will raise
2999 -- constraint error which is fine.
3001 when Attribute_Compose
=>
3002 Expand_Fpt_Attribute_RI
(N
);
3008 when Attribute_Constrained
=> Constrained
: declare
3009 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
3012 -- Reference to a parameter where the value is passed as an extra
3013 -- actual, corresponding to the extra formal referenced by the
3014 -- Extra_Constrained field of the corresponding formal. If this
3015 -- is an entry in-parameter, it is replaced by a constant renaming
3016 -- for which Extra_Constrained is never created.
3018 if Present
(Formal_Ent
)
3019 and then Ekind
(Formal_Ent
) /= E_Constant
3020 and then Present
(Extra_Constrained
(Formal_Ent
))
3024 (Extra_Constrained
(Formal_Ent
), Loc
));
3026 -- If the prefix is an access to object, the attribute applies to
3027 -- the designated object, so rewrite with an explicit dereference.
3029 elsif Is_Access_Type
(Ptyp
)
3031 (not Is_Entity_Name
(Pref
) or else Is_Object
(Entity
(Pref
)))
3034 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Pref
)));
3036 -- For variables with a Extra_Constrained field, we use the
3037 -- corresponding entity.
3039 elsif Nkind
(Pref
) = N_Identifier
3040 and then Ekind
(Entity
(Pref
)) = E_Variable
3041 and then Present
(Extra_Constrained
(Entity
(Pref
)))
3045 (Extra_Constrained
(Entity
(Pref
)), Loc
));
3047 -- For all other cases, we can tell at compile time
3050 -- For access type, apply access check as needed
3052 if Is_Entity_Name
(Pref
)
3053 and then not Is_Type
(Entity
(Pref
))
3054 and then Is_Access_Type
(Ptyp
)
3056 Apply_Access_Check
(N
);
3062 (Exp_Util
.Attribute_Constrained_Static_Value
(Pref
)), Loc
));
3065 Analyze_And_Resolve
(N
, Standard_Boolean
);
3072 -- Transforms 'Copy_Sign into a call to the floating-point attribute
3073 -- function Copy_Sign in Fat_xxx (where xxx is the root type).
3075 when Attribute_Copy_Sign
=>
3076 Expand_Fpt_Attribute_RR
(N
);
3082 -- Transforms 'Count attribute into a call to the Count function
3084 when Attribute_Count
=> Count
: declare
3086 Conctyp
: Entity_Id
;
3088 Entry_Id
: Entity_Id
;
3093 -- If the prefix is a member of an entry family, retrieve both
3094 -- entry name and index. For a simple entry there is no index.
3096 if Nkind
(Pref
) = N_Indexed_Component
then
3097 Entnam
:= Prefix
(Pref
);
3098 Index
:= First
(Expressions
(Pref
));
3104 Entry_Id
:= Entity
(Entnam
);
3106 -- Find the concurrent type in which this attribute is referenced
3107 -- (there had better be one).
3109 Conctyp
:= Current_Scope
;
3110 while not Is_Concurrent_Type
(Conctyp
) loop
3111 Conctyp
:= Scope
(Conctyp
);
3116 if Is_Protected_Type
(Conctyp
) then
3118 -- No need to transform 'Count into a function call if the current
3119 -- scope has been eliminated. In this case such transformation is
3120 -- also not viable because the enclosing protected object is not
3123 if Is_Eliminated
(Current_Scope
) then
3127 case Corresponding_Runtime_Package
(Conctyp
) is
3128 when System_Tasking_Protected_Objects_Entries
=>
3129 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
3132 Make_Function_Call
(Loc
,
3134 Parameter_Associations
=> New_List
(
3136 (Find_Protection_Object
(Current_Scope
), Loc
),
3137 Entry_Index_Expression
3138 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
3140 when System_Tasking_Protected_Objects_Single_Entry
=>
3142 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
3145 Make_Function_Call
(Loc
,
3147 Parameter_Associations
=> New_List
(
3149 (Find_Protection_Object
(Current_Scope
), Loc
)));
3152 raise Program_Error
;
3159 Make_Function_Call
(Loc
,
3160 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
3161 Parameter_Associations
=> New_List
(
3162 Entry_Index_Expression
(Loc
,
3163 Entry_Id
, Index
, Scope
(Entry_Id
))));
3166 -- The call returns type Natural but the context is universal integer
3167 -- so any integer type is allowed. The attribute was already resolved
3168 -- so its Etype is the required result type. If the base type of the
3169 -- context type is other than Standard.Integer we put in a conversion
3170 -- to the required type. This can be a normal typed conversion since
3171 -- both input and output types of the conversion are integer types
3173 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
3174 Rewrite
(N
, Convert_To
(Typ
, Call
));
3179 Analyze_And_Resolve
(N
, Typ
);
3182 ---------------------
3183 -- Descriptor_Size --
3184 ---------------------
3186 -- Descriptor_Size is handled by the back end
3188 when Attribute_Descriptor_Size
=>
3189 Apply_Universal_Integer_Attribute_Checks
(N
);
3195 -- This processing is shared by Elab_Spec
3197 -- What we do is to insert the following declarations
3200 -- pragma Import (C, enn, "name___elabb/s");
3202 -- and then the Elab_Body/Spec attribute is replaced by a reference
3203 -- to this defining identifier.
3205 when Attribute_Elab_Body
3206 | Attribute_Elab_Spec
3208 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3209 -- back-end knows how to handle these attributes directly.
3211 if CodePeer_Mode
then
3216 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
3220 procedure Make_Elab_String
(Nod
: Node_Id
);
3221 -- Given Nod, an identifier, or a selected component, put the
3222 -- image into the current string literal, with double underline
3223 -- between components.
3225 ----------------------
3226 -- Make_Elab_String --
3227 ----------------------
3229 procedure Make_Elab_String
(Nod
: Node_Id
) is
3231 if Nkind
(Nod
) = N_Selected_Component
then
3232 Make_Elab_String
(Prefix
(Nod
));
3233 Store_String_Char
('_');
3234 Store_String_Char
('_');
3235 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
3238 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
3239 Get_Name_String
(Chars
(Nod
));
3242 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3243 end Make_Elab_String
;
3245 -- Start of processing for Elab_Body/Elab_Spec
3248 -- First we need to prepare the string literal for the name of
3249 -- the elaboration routine to be referenced.
3252 Make_Elab_String
(Pref
);
3253 Store_String_Chars
("___elab");
3254 Lang
:= Make_Identifier
(Loc
, Name_C
);
3256 if Id
= Attribute_Elab_Body
then
3257 Store_String_Char
('b');
3259 Store_String_Char
('s');
3264 Insert_Actions
(N
, New_List
(
3265 Make_Subprogram_Declaration
(Loc
,
3267 Make_Procedure_Specification
(Loc
,
3268 Defining_Unit_Name
=> Ent
)),
3271 Chars
=> Name_Import
,
3272 Pragma_Argument_Associations
=> New_List
(
3273 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3275 Make_Pragma_Argument_Association
(Loc
,
3276 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3278 Make_Pragma_Argument_Association
(Loc
,
3279 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3281 Set_Entity
(N
, Ent
);
3282 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3285 --------------------
3286 -- Elab_Subp_Body --
3287 --------------------
3289 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3290 -- this attribute directly, and if we are not in CodePeer mode it is
3291 -- entirely ignored ???
3293 when Attribute_Elab_Subp_Body
=>
3300 -- Elaborated is always True for preelaborated units, predefined units,
3301 -- pure units and units which have Elaborate_Body pragmas. These units
3302 -- have no elaboration entity.
3304 -- Note: The Elaborated attribute is never passed to the back end
3306 when Attribute_Elaborated
=> Elaborated
: declare
3307 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3310 if Present
(Elab_Id
) then
3313 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3314 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3316 Analyze_And_Resolve
(N
, Typ
);
3318 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3326 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3330 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3333 if Is_Non_Empty_List
(Exprs
) then
3334 Expr
:= First
(Exprs
);
3339 -- If not constant-folded, Enum_Type'Enum_Rep (X) or X'Enum_Rep
3344 -- This is an unchecked conversion from the enumeration type to the
3345 -- target integer type, which is treated by the back end as a normal
3346 -- integer conversion, treating the enumeration type as an integer,
3347 -- which is exactly what we want. Unlike for the Pos attribute, we
3348 -- cannot use a regular conversion since the associated check would
3349 -- involve comparing the converted bounds, i.e. would involve the use
3350 -- of 'Pos instead 'Enum_Rep for these bounds.
3352 -- However the target type is universal integer in most cases, which
3353 -- is a very large type, so in the case of an enumeration type, we
3354 -- first convert to a small signed integer type in order not to lose
3355 -- the size information.
3357 if Is_Enumeration_Type
(Ptyp
) then
3358 Rewrite
(N
, Unchecked_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
3359 Convert_To_And_Rewrite
(Typ
, N
);
3361 -- Deal with integer types (replace by conversion)
3364 Rewrite
(N
, Convert_To
(Typ
, Expr
));
3367 Analyze_And_Resolve
(N
, Typ
);
3374 when Attribute_Enum_Val
=> Enum_Val
: declare
3376 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3379 -- X'Enum_Val (Y) expands to
3381 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3384 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3386 -- Ensure that the expression is not truncated since the "bad" bits
3389 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
3390 Set_No_Truncation
(Expr
);
3394 Make_Raise_Constraint_Error
(Loc
,
3398 Make_Function_Call
(Loc
,
3400 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3401 Parameter_Associations
=> New_List
(
3402 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3403 New_Occurrence_Of
(Standard_False
, Loc
))),
3405 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3406 Reason
=> CE_Range_Check_Failed
));
3409 Analyze_And_Resolve
(N
, Ptyp
);
3416 -- Transforms 'Exponent into a call to the floating-point attribute
3417 -- function Exponent in Fat_xxx (where xxx is the root type)
3419 when Attribute_Exponent
=>
3420 Expand_Fpt_Attribute_R
(N
);
3426 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3428 when Attribute_External_Tag
=>
3430 Make_Function_Call
(Loc
,
3432 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3433 Parameter_Associations
=> New_List
(
3434 Make_Attribute_Reference
(Loc
,
3435 Attribute_Name
=> Name_Tag
,
3436 Prefix
=> Prefix
(N
)))));
3438 Analyze_And_Resolve
(N
, Standard_String
);
3440 -----------------------
3441 -- Finalization_Size --
3442 -----------------------
3444 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3445 function Calculate_Header_Size
return Node_Id
;
3446 -- Generate a runtime call to calculate the size of the hidden header
3447 -- along with any added padding which would precede a heap-allocated
3448 -- object of the prefix type.
3450 ---------------------------
3451 -- Calculate_Header_Size --
3452 ---------------------------
3454 function Calculate_Header_Size
return Node_Id
is
3457 -- Typ (Header_Size_With_Padding (Pref'Alignment))
3461 Make_Function_Call
(Loc
,
3463 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3465 Parameter_Associations
=> New_List
(
3466 Make_Attribute_Reference
(Loc
,
3467 Prefix
=> New_Copy_Tree
(Pref
),
3468 Attribute_Name
=> Name_Alignment
))));
3469 end Calculate_Header_Size
;
3475 -- Start of processing for Finalization_Size
3478 -- An object of a class-wide type first requires a runtime check to
3479 -- determine whether it is actually controlled or not. Depending on
3480 -- the outcome of this check, the Finalization_Size of the object
3481 -- may be zero or some positive value.
3483 -- In this scenario, Pref'Finalization_Size is expanded into
3485 -- Size : Integer := 0;
3487 -- if Needs_Finalization (Pref'Tag) then
3488 -- Size := Integer (Header_Size_With_Padding (Pref'Alignment));
3491 -- and the attribute reference is replaced with a reference to Size.
3493 if Is_Class_Wide_Type
(Ptyp
) then
3494 Size
:= Make_Temporary
(Loc
, 'S');
3496 Insert_Actions
(N
, New_List
(
3499 -- Size : Integer := 0;
3501 Make_Object_Declaration
(Loc
,
3502 Defining_Identifier
=> Size
,
3503 Object_Definition
=>
3504 New_Occurrence_Of
(Standard_Integer
, Loc
),
3505 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3508 -- if Needs_Finalization (Pref'Tag) then
3510 -- Integer (Header_Size_With_Padding (Pref'Alignment));
3513 Make_If_Statement
(Loc
,
3515 Make_Function_Call
(Loc
,
3517 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3519 Parameter_Associations
=> New_List
(
3520 Make_Attribute_Reference
(Loc
,
3521 Prefix
=> New_Copy_Tree
(Pref
),
3522 Attribute_Name
=> Name_Tag
))),
3524 Then_Statements
=> New_List
(
3525 Make_Assignment_Statement
(Loc
,
3526 Name
=> New_Occurrence_Of
(Size
, Loc
),
3529 (Standard_Integer
, Calculate_Header_Size
))))));
3531 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3533 -- The prefix is known to be controlled at compile time. Calculate
3534 -- Finalization_Size by calling function Header_Size_With_Padding.
3536 elsif Needs_Finalization
(Ptyp
) then
3537 Rewrite
(N
, Calculate_Header_Size
);
3539 -- The prefix is not an object with controlled parts, so its
3540 -- Finalization_Size is zero.
3543 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3546 -- Due to cases where the entity type of the attribute is already
3547 -- resolved the rewritten N must get re-resolved to its appropriate
3550 Analyze_And_Resolve
(N
, Typ
);
3551 end Finalization_Size
;
3557 when Attribute_First
3560 -- If the prefix type is a constrained packed array type which
3561 -- already has a Packed_Array_Impl_Type representation defined, then
3562 -- replace this attribute with a direct reference to the attribute of
3563 -- the appropriate index subtype (since otherwise the back end will
3564 -- try to give us the value of 'First for this implementation type).
3565 -- Do not do this if Ptyp depends on a discriminant as its bounds
3566 -- are only available through N.
3568 if Is_Constrained_Packed_Array
(Ptyp
)
3569 and then not Size_Depends_On_Discriminant
(Ptyp
)
3572 Make_Attribute_Reference
(Loc
,
3573 Attribute_Name
=> Attribute_Name
(N
),
3575 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3576 Analyze_And_Resolve
(N
, Typ
);
3578 -- For a constrained array type, if the bound is a reference to an
3579 -- entity which is not a discriminant, just replace with a direct
3580 -- reference. Note that this must be in keeping with what is done
3581 -- for scalar types in order for range checks to be elided in loops.
3583 -- However, avoid doing it if the array type is public because, in
3584 -- this case, we effectively rely on the back end to create public
3585 -- symbols with consistent names across units for the array bounds.
3587 elsif Is_Array_Type
(Ptyp
)
3588 and then Is_Constrained
(Ptyp
)
3589 and then not Is_Public
(Ptyp
)
3595 if Id
= Attribute_First
then
3596 Bnd
:= Type_Low_Bound
(Get_Index_Subtype
(N
));
3598 Bnd
:= Type_High_Bound
(Get_Index_Subtype
(N
));
3601 if Is_Entity_Name
(Bnd
)
3602 and then Ekind
(Entity
(Bnd
)) /= E_Discriminant
3604 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3608 -- For access type, apply access check as needed
3610 elsif Is_Access_Type
(Ptyp
) then
3611 Apply_Access_Check
(N
);
3613 -- For scalar type, if the bound is a reference to an entity, just
3614 -- replace with a direct reference. Note that we can only have a
3615 -- reference to a constant entity at this stage, anything else would
3616 -- have already been rewritten.
3618 elsif Is_Scalar_Type
(Ptyp
) then
3623 if Id
= Attribute_First
then
3624 Bnd
:= Type_Low_Bound
(Ptyp
);
3626 Bnd
:= Type_High_Bound
(Ptyp
);
3629 if Is_Entity_Name
(Bnd
) then
3630 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3639 -- We leave the computation up to the back end, since we don't know what
3640 -- layout will be chosen if no component clause was specified.
3642 when Attribute_First_Bit
=>
3643 Apply_Universal_Integer_Attribute_Checks
(N
);
3645 --------------------------------
3646 -- Fixed_Value, Integer_Value --
3647 --------------------------------
3651 -- fixtype'Fixed_Value (integer-value)
3652 -- inttype'Integer_Value (fixed-value)
3656 -- fixtype (integer-value)
3657 -- inttype (fixed-value)
3661 -- We set Conversion_OK on the conversion because we do not want it
3662 -- to go through the fixed-point conversion circuits.
3664 when Attribute_Fixed_Value
3665 | Attribute_Integer_Value
3667 Rewrite
(N
, OK_Convert_To
(Entity
(Pref
), First
(Exprs
)));
3669 -- Note that it might appear that a properly analyzed unchecked
3670 -- conversion would be just fine here, but that's not the case,
3671 -- since the full range checks performed by the following calls
3674 Apply_Type_Conversion_Checks
(N
);
3676 -- Note that Apply_Type_Conversion_Checks only deals with the
3677 -- overflow checks on conversions involving fixed-point types
3678 -- so we must apply range checks manually on them and expand.
3680 Apply_Scalar_Range_Check
3681 (Expression
(N
), Etype
(N
), Fixed_Int
=> True);
3690 -- Transforms 'Floor into a call to the floating-point attribute
3691 -- function Floor in Fat_xxx (where xxx is the root type)
3693 when Attribute_Floor
=>
3694 Expand_Fpt_Attribute_R
(N
);
3700 -- For the fixed-point type Typ:
3706 -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm])
3708 -- For decimal fixed-point types
3709 -- xx = Decimal{32,64,128}
3710 -- ftyp = Integer_{32,64,128}
3713 -- For the most common ordinary fixed-point types
3714 -- xx = Fixed{32,64,128}
3715 -- ftyp = Integer_{32,64,128}
3716 -- pm = numerator of Typ'Small
3717 -- denominator of Typ'Small
3718 -- min (scale of Typ'Small, 0)
3720 -- For other ordinary fixed-point types
3722 -- ftyp = Long_Float
3725 -- Note that we know that the type is a nonstatic subtype, or Fore would
3726 -- have been computed statically in Eval_Attribute.
3728 when Attribute_Fore
=>
3735 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3736 if Esize
(Ptyp
) <= 32 then
3737 Fid
:= RE_Fore_Decimal32
;
3738 Ftyp
:= RTE
(RE_Integer_32
);
3739 elsif Esize
(Ptyp
) <= 64 then
3740 Fid
:= RE_Fore_Decimal64
;
3741 Ftyp
:= RTE
(RE_Integer_64
);
3743 Fid
:= RE_Fore_Decimal128
;
3744 Ftyp
:= RTE
(RE_Integer_128
);
3749 Num
: constant Uint
:= Norm_Num
(Small_Value
(Ptyp
));
3750 Den
: constant Uint
:= Norm_Den
(Small_Value
(Ptyp
));
3751 Max
: constant Uint
:= UI_Max
(Num
, Den
);
3752 Min
: constant Uint
:= UI_Min
(Num
, Den
);
3753 Siz
: constant Uint
:= Esize
(Ptyp
);
3757 and then Max
<= Uint_2
** 31
3758 and then (Min
= Uint_1
3760 or else Num
< Uint_10
** 8)
3762 Fid
:= RE_Fore_Fixed32
;
3763 Ftyp
:= RTE
(RE_Integer_32
);
3765 and then Max
<= Uint_2
** 63
3766 and then (Min
= Uint_1
3768 or else Num
< Uint_10
** 17)
3770 Fid
:= RE_Fore_Fixed64
;
3771 Ftyp
:= RTE
(RE_Integer_64
);
3772 elsif System_Max_Integer_Size
= 128
3773 and then Max
<= Uint_2
** 127
3774 and then (Min
= Uint_1
3776 or else Num
< Uint_10
** 37)
3778 Fid
:= RE_Fore_Fixed128
;
3779 Ftyp
:= RTE
(RE_Integer_128
);
3781 Fid
:= RE_Fore_Fixed
;
3782 Ftyp
:= Standard_Long_Float
;
3787 Arg_List
:= New_List
(
3789 Make_Attribute_Reference
(Loc
,
3790 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3791 Attribute_Name
=> Name_First
)));
3793 Append_To
(Arg_List
,
3795 Make_Attribute_Reference
(Loc
,
3796 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3797 Attribute_Name
=> Name_Last
)));
3799 -- For decimal, append Scale and also set to do literal conversion
3801 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3802 Set_Conversion_OK
(First
(Arg_List
));
3803 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3805 Append_To
(Arg_List
,
3806 Make_Integer_Literal
(Loc
, Scale_Value
(Ptyp
)));
3808 -- For ordinary fixed-point types, append Num, Den and Scale
3809 -- parameters and also set to do literal conversion
3811 elsif Fid
/= RE_Fore_Fixed
then
3812 Set_Conversion_OK
(First
(Arg_List
));
3813 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3815 Append_To
(Arg_List
,
3816 Make_Integer_Literal
(Loc
, -Norm_Num
(Small_Value
(Ptyp
))));
3818 Append_To
(Arg_List
,
3819 Make_Integer_Literal
(Loc
, -Norm_Den
(Small_Value
(Ptyp
))));
3822 Val
: Ureal
:= Small_Value
(Ptyp
);
3826 while Val
>= Ureal_10
loop
3827 Val
:= Val
/ Ureal_10
;
3831 Append_To
(Arg_List
,
3832 Make_Integer_Literal
(Loc
, UI_From_Int
(Scale
)));
3838 Make_Function_Call
(Loc
,
3840 New_Occurrence_Of
(RTE
(Fid
), Loc
),
3841 Parameter_Associations
=> Arg_List
)));
3843 Analyze_And_Resolve
(N
, Typ
);
3850 -- Transforms 'Fraction into a call to the floating-point attribute
3851 -- function Fraction in Fat_xxx (where xxx is the root type)
3853 when Attribute_Fraction
=>
3854 Expand_Fpt_Attribute_R
(N
);
3860 when Attribute_From_Any
=> From_Any
: declare
3861 Decls
: constant List_Id
:= New_List
;
3865 Build_From_Any_Call
(Ptyp
,
3866 Relocate_Node
(First
(Exprs
)),
3868 Insert_Actions
(N
, Decls
);
3869 Analyze_And_Resolve
(N
, Ptyp
);
3872 ----------------------
3873 -- Has_Same_Storage --
3874 ----------------------
3876 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3877 Loc
: constant Source_Ptr
:= Sloc
(N
);
3879 X
: constant Node_Id
:= Prefix
(N
);
3880 Y
: constant Node_Id
:= First
(Expressions
(N
));
3885 -- Rhe expressions for their addresses
3889 -- Rhe expressions for their sizes
3892 -- The attribute is expanded as:
3894 -- (X'address = Y'address)
3895 -- and then (X'Size = Y'Size)
3896 -- and then (X'Size /= 0) (AI12-0077)
3898 -- If both arguments have the same Etype the second conjunct can be
3902 Make_Attribute_Reference
(Loc
,
3903 Attribute_Name
=> Name_Address
,
3904 Prefix
=> New_Copy_Tree
(X
));
3907 Make_Attribute_Reference
(Loc
,
3908 Attribute_Name
=> Name_Address
,
3909 Prefix
=> New_Copy_Tree
(Y
));
3912 Make_Attribute_Reference
(Loc
,
3913 Attribute_Name
=> Name_Size
,
3914 Prefix
=> New_Copy_Tree
(X
));
3916 if Etype
(X
) = Etype
(Y
) then
3921 Left_Opnd
=> X_Addr
,
3922 Right_Opnd
=> Y_Addr
),
3925 Left_Opnd
=> X_Size
,
3926 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))));
3929 Make_Attribute_Reference
(Loc
,
3930 Attribute_Name
=> Name_Size
,
3931 Prefix
=> New_Copy_Tree
(Y
));
3937 Left_Opnd
=> X_Addr
,
3938 Right_Opnd
=> Y_Addr
),
3943 Left_Opnd
=> X_Size
,
3944 Right_Opnd
=> Y_Size
),
3947 Left_Opnd
=> New_Copy_Tree
(X_Size
),
3948 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)))));
3951 Analyze_And_Resolve
(N
, Standard_Boolean
);
3952 end Has_Same_Storage
;
3958 -- For an exception returns a reference to the exception data:
3959 -- Exception_Id!(Prefix'Reference)
3961 -- For a task it returns a reference to the _task_id component of
3962 -- corresponding record:
3964 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3966 -- in Ada.Task_Identification
3968 when Attribute_Identity
=> Identity
: declare
3969 Id_Kind
: Entity_Id
;
3972 if Ptyp
= Standard_Exception_Type
then
3973 Id_Kind
:= RTE
(RE_Exception_Id
);
3975 if Present
(Renamed_Entity
(Entity
(Pref
))) then
3976 Set_Entity
(Pref
, Renamed_Entity
(Entity
(Pref
)));
3980 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3982 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3984 -- If the prefix is a task interface, the Task_Id is obtained
3985 -- dynamically through a dispatching call, as for other task
3986 -- attributes applied to interfaces.
3988 if Ada_Version
>= Ada_2005
3989 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3990 and then Is_Interface
(Ptyp
)
3991 and then Is_Task_Interface
(Ptyp
)
3994 Unchecked_Convert_To
3995 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
3999 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
4003 Analyze_And_Resolve
(N
, Id_Kind
);
4010 when Attribute_Image
=>
4012 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
4013 -- back-end knows how to handle this attribute directly.
4015 if CodePeer_Mode
then
4019 Exp_Imgv
.Expand_Image_Attribute
(N
);
4025 -- X'Img is expanded to typ'Image (X), where typ is the type of X
4027 when Attribute_Img
=>
4028 Exp_Imgv
.Expand_Image_Attribute
(N
);
4034 -- Transforms 'Index attribute into a reference to the second formal of
4035 -- the wrapper built for an entry family that has contract cases (see
4036 -- Exp_Ch9.Build_Contract_Wrapper).
4038 when Attribute_Index
=> Index
: declare
4039 Entry_Id
: constant Entity_Id
:= Entity
(Pref
);
4040 Entry_Idx
: constant Entity_Id
:=
4042 (First_Entity
(Contract_Wrapper
(Entry_Id
)));
4044 Rewrite
(N
, New_Occurrence_Of
(Entry_Idx
, Loc
));
4045 Analyze_And_Resolve
(N
, Typ
);
4052 -- For execution, we could either implement an approximation of this
4053 -- aspect, or use Valid_Scalars as a first approximation. For now we do
4056 when Attribute_Initialized
=>
4058 -- Do not expand 'Initialized in CodePeer mode, it will be handled
4059 -- by the back-end directly.
4061 if CodePeer_Mode
then
4067 Make_Attribute_Reference
4070 Attribute_Name
=> Name_Valid_Scalars
,
4071 Expressions
=> Exprs
));
4073 Analyze_And_Resolve
(N
);
4079 when Attribute_Input
=> Input
: declare
4080 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4081 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
4082 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4083 Strm
: constant Node_Id
:= First
(Exprs
);
4091 Cntrl
: Node_Id
:= Empty
;
4092 -- Value for controlling argument in call. Always Empty except in
4093 -- the dispatching (class-wide type) case, where it is a reference
4094 -- to the dummy object initialized to the right internal tag.
4096 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
4097 -- The expansion of the attribute reference may generate a call to
4098 -- a user-defined stream subprogram that is frozen by the call. This
4099 -- can lead to access-before-elaboration problem if the reference
4100 -- appears in an object declaration and the subprogram body has not
4101 -- been seen. The freezing of the subprogram requires special code
4102 -- because it appears in an expanded context where expressions do
4103 -- not freeze their constituents.
4105 ------------------------------
4106 -- Freeze_Stream_Subprogram --
4107 ------------------------------
4109 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
4110 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
4114 -- If this is user-defined subprogram, the corresponding
4115 -- stream function appears as a renaming-as-body, and the
4116 -- user subprogram must be retrieved by tree traversal.
4119 and then Nkind
(Decl
) = N_Subprogram_Declaration
4120 and then Present
(Corresponding_Body
(Decl
))
4122 Bod
:= Corresponding_Body
(Decl
);
4124 if Nkind
(Unit_Declaration_Node
(Bod
)) =
4125 N_Subprogram_Renaming_Declaration
4127 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
4130 end Freeze_Stream_Subprogram
;
4132 -- Start of processing for Input
4135 -- If no underlying type, we have an error that will be diagnosed
4136 -- elsewhere, so here we just completely ignore the expansion.
4142 -- Stream operations can appear in user code even if the restriction
4143 -- No_Streams is active (for example, when instantiating a predefined
4144 -- container). In that case rewrite the attribute as a Raise to
4145 -- prevent any run-time use.
4147 if Restriction_Active
(No_Streams
) then
4149 Make_Raise_Program_Error
(Sloc
(N
),
4150 Reason
=> PE_Stream_Operation_Not_Allowed
));
4151 Set_Etype
(N
, B_Type
);
4155 -- If there is a TSS for Input, just call it
4157 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
4159 if Present
(Fname
) then
4163 -- If there is a Stream_Convert pragma, use it, we rewrite
4165 -- sourcetyp'Input (stream)
4169 -- sourcetyp (streamread (strmtyp'Input (stream)));
4171 -- where streamread is the given Read function that converts an
4172 -- argument of type strmtyp to type sourcetyp or a type from which
4173 -- it is derived (extra conversion required for the derived case).
4175 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4177 if Present
(Prag
) then
4178 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4179 Rfunc
:= Entity
(Expression
(Arg2
));
4183 Make_Function_Call
(Loc
,
4184 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4185 Parameter_Associations
=> New_List
(
4186 Make_Attribute_Reference
(Loc
,
4189 (Etype
(First_Formal
(Rfunc
)), Loc
),
4190 Attribute_Name
=> Name_Input
,
4191 Expressions
=> Exprs
)))));
4193 Analyze_And_Resolve
(N
, B_Type
);
4198 elsif Default_Streaming_Unavailable
(U_Type
) then
4199 -- Do the same thing here as is done above in the
4200 -- case where a No_Streams restriction is active.
4203 Make_Raise_Program_Error
(Sloc
(N
),
4204 Reason
=> PE_Stream_Operation_Not_Allowed
));
4205 Set_Etype
(N
, B_Type
);
4210 elsif Is_Elementary_Type
(U_Type
) then
4212 -- A special case arises if we have a defined _Read routine,
4213 -- since in this case we are required to call this routine.
4215 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Read
)) then
4216 Build_Record_Or_Elementary_Input_Function
4217 (Loc
, P_Type
, Decl
, Fname
);
4218 Insert_Action
(N
, Decl
);
4220 -- For normal cases, we call the I_xxx routine directly
4223 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
4224 Analyze_And_Resolve
(N
, P_Type
);
4230 elsif Is_Array_Type
(U_Type
) then
4231 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
4232 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
4234 -- Dispatching case with class-wide type
4236 elsif Is_Class_Wide_Type
(P_Type
) then
4238 -- No need to do anything else compiling under restriction
4239 -- No_Dispatching_Calls. During the semantic analysis we
4240 -- already notified such violation.
4242 if Restriction_Active
(No_Dispatching_Calls
) then
4247 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
4249 Expr
: Node_Id
; -- call to Descendant_Tag
4250 Get_Tag
: Node_Id
; -- expression to read the 'Tag
4253 -- Read the internal tag (RM 13.13.2(34)) and use it to
4254 -- initialize a dummy tag value. We used to unconditionally
4257 -- Descendant_Tag (String'Input (Strm), P_Type);
4259 -- which turns into a call to String_Input_Blk_IO. However,
4260 -- if the input is malformed, that could try to read an
4261 -- enormous String, causing chaos. So instead we call
4262 -- String_Input_Tag, which does the same thing as
4263 -- String_Input_Blk_IO, except that if the String is
4264 -- absurdly long, it raises an exception.
4266 -- However, if the No_Stream_Optimizations restriction
4267 -- is active, we disable this unnecessary attempt at
4268 -- robustness; we really need to read the string
4269 -- character-by-character.
4271 -- This value is used only to provide a controlling
4272 -- argument for the eventual _Input call. Descendant_Tag is
4273 -- called rather than Internal_Tag to ensure that we have a
4274 -- tag for a type that is descended from the prefix type and
4275 -- declared at the same accessibility level (the exception
4276 -- Tag_Error will be raised otherwise). The level check is
4277 -- required for Ada 2005 because tagged types can be
4278 -- extended in nested scopes (AI-344).
4280 -- Note: we used to generate an explicit declaration of a
4281 -- constant Ada.Tags.Tag object, and use an occurrence of
4282 -- this constant in Cntrl, but this caused a secondary stack
4285 if Restriction_Active
(No_Stream_Optimizations
) then
4287 Make_Attribute_Reference
(Loc
,
4289 New_Occurrence_Of
(Standard_String
, Loc
),
4290 Attribute_Name
=> Name_Input
,
4291 Expressions
=> New_List
(
4292 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4295 Make_Function_Call
(Loc
,
4298 (RTE
(RE_String_Input_Tag
), Loc
),
4299 Parameter_Associations
=> New_List
(
4300 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4304 Make_Function_Call
(Loc
,
4306 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
4307 Parameter_Associations
=> New_List
(
4309 Make_Attribute_Reference
(Loc
,
4310 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
4311 Attribute_Name
=> Name_Tag
)));
4313 Set_Etype
(Expr
, RTE
(RE_Tag
));
4315 -- Now we need to get the entity for the call, and construct
4316 -- a function call node, where we preset a reference to Dnn
4317 -- as the controlling argument (doing an unchecked convert
4318 -- to the class-wide tagged type to make it look like a real
4321 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
4322 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
4323 Set_Etype
(Cntrl
, P_Type
);
4324 Set_Parent
(Cntrl
, N
);
4327 -- For tagged types, use the primitive Input function
4329 elsif Is_Tagged_Type
(U_Type
) then
4330 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
4332 -- All other record type cases, including protected records. The
4333 -- latter only arise for expander generated code for handling
4334 -- shared passive partition access.
4338 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4340 -- Ada 2005 (AI-216): Program_Error is raised executing default
4341 -- implementation of the Input attribute of an unchecked union
4342 -- type if the type lacks default discriminant values.
4344 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4346 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
4349 Make_Raise_Program_Error
(Loc
,
4350 Reason
=> PE_Unchecked_Union_Restriction
));
4351 Set_Etype
(N
, B_Type
);
4355 -- Build the type's Input function, passing the subtype rather
4356 -- than its base type, because checks are needed in the case of
4357 -- constrained discriminants (see Ada 2012 AI05-0192).
4359 Build_Record_Or_Elementary_Input_Function
4360 (Loc
, U_Type
, Decl
, Fname
);
4361 Insert_Action
(N
, Decl
);
4363 if Nkind
(Parent
(N
)) = N_Object_Declaration
4364 and then Is_Record_Type
(U_Type
)
4366 -- The stream function may contain calls to user-defined
4367 -- Read procedures for individual components.
4374 Comp
:= First_Component
(U_Type
);
4375 while Present
(Comp
) loop
4377 Find_Stream_Subprogram
4378 (Etype
(Comp
), TSS_Stream_Read
);
4380 if Present
(Func
) then
4381 Freeze_Stream_Subprogram
(Func
);
4384 Next_Component
(Comp
);
4391 -- If we fall through, Fname is the function to be called. The result
4392 -- is obtained by calling the appropriate function, then converting
4393 -- the result. The conversion does a subtype check.
4396 Make_Function_Call
(Loc
,
4397 Name
=> New_Occurrence_Of
(Fname
, Loc
),
4398 Parameter_Associations
=> New_List
(
4399 Relocate_Node
(Strm
)));
4401 Set_Controlling_Argument
(Call
, Cntrl
);
4402 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
4403 Analyze_And_Resolve
(N
, P_Type
);
4405 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4406 Freeze_Stream_Subprogram
(Fname
);
4414 when Attribute_Invalid_Value
=>
4415 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
4417 -- The value produced may be a conversion of a literal, which must be
4418 -- resolved to establish its proper type.
4420 Analyze_And_Resolve
(N
);
4426 -- We leave the computation up to the back end, since we don't know what
4427 -- layout will be chosen if no component clause was specified.
4429 when Attribute_Last_Bit
=>
4430 Apply_Universal_Integer_Attribute_Checks
(N
);
4436 -- Transforms 'Leading_Part into a call to the floating-point attribute
4437 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4439 -- Note: strictly, we should generate special case code to deal with
4440 -- absurdly large positive arguments (greater than Integer'Last), which
4441 -- result in returning the first argument unchanged, but it hardly seems
4442 -- worth the effort. We raise constraint error for absurdly negative
4443 -- arguments which is fine.
4445 when Attribute_Leading_Part
=>
4446 Expand_Fpt_Attribute_RI
(N
);
4452 when Attribute_Length
=> Length
: declare
4457 -- Processing for packed array types
4459 if Is_Packed_Array
(Ptyp
) then
4460 Ityp
:= Get_Index_Subtype
(N
);
4462 -- If the index type, Ityp, is an enumeration type with holes,
4463 -- then we calculate X'Length explicitly using
4466 -- (0, Ityp'Pos (X'Last (N)) -
4467 -- Ityp'Pos (X'First (N)) + 1);
4469 -- Since the bounds in the template are the representation values
4470 -- and the back end would get the wrong value.
4472 if Is_Enumeration_Type
(Ityp
)
4473 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4478 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4482 Make_Attribute_Reference
(Loc
,
4483 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4484 Attribute_Name
=> Name_Max
,
4485 Expressions
=> New_List
4486 (Make_Integer_Literal
(Loc
, 0),
4490 Make_Op_Subtract
(Loc
,
4492 Make_Attribute_Reference
(Loc
,
4493 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4494 Attribute_Name
=> Name_Pos
,
4496 Expressions
=> New_List
(
4497 Make_Attribute_Reference
(Loc
,
4498 Prefix
=> Duplicate_Subexpr
(Pref
),
4499 Attribute_Name
=> Name_Last
,
4500 Expressions
=> New_List
(
4501 Make_Integer_Literal
(Loc
, Xnum
))))),
4504 Make_Attribute_Reference
(Loc
,
4505 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4506 Attribute_Name
=> Name_Pos
,
4508 Expressions
=> New_List
(
4509 Make_Attribute_Reference
(Loc
,
4511 Duplicate_Subexpr_No_Checks
(Pref
),
4512 Attribute_Name
=> Name_First
,
4513 Expressions
=> New_List
(
4514 Make_Integer_Literal
(Loc
, Xnum
)))))),
4516 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4518 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4521 -- If the prefix type is a constrained packed array type which
4522 -- already has a Packed_Array_Impl_Type representation defined,
4523 -- then replace this attribute with a reference to 'Range_Length
4524 -- of the appropriate index subtype (since otherwise the
4525 -- back end will try to give us the value of 'Length for
4526 -- this implementation type).s
4528 elsif Is_Constrained
(Ptyp
) then
4530 Make_Attribute_Reference
(Loc
,
4531 Attribute_Name
=> Name_Range_Length
,
4532 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4533 Analyze_And_Resolve
(N
, Typ
);
4538 elsif Is_Access_Type
(Ptyp
) then
4539 Apply_Access_Check
(N
);
4541 -- If the designated type is a packed array type, then we convert
4542 -- the reference to:
4545 -- xtyp'Pos (Pref'Last (Expr)) -
4546 -- xtyp'Pos (Pref'First (Expr)));
4548 -- This is a bit complex, but it is the easiest thing to do that
4549 -- works in all cases including enum types with holes xtyp here
4550 -- is the appropriate index type.
4553 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4557 if Is_Packed_Array
(Dtyp
) then
4558 Xtyp
:= Get_Index_Subtype
(N
);
4561 Make_Attribute_Reference
(Loc
,
4562 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4563 Attribute_Name
=> Name_Max
,
4564 Expressions
=> New_List
(
4565 Make_Integer_Literal
(Loc
, 0),
4568 Make_Integer_Literal
(Loc
, 1),
4569 Make_Op_Subtract
(Loc
,
4571 Make_Attribute_Reference
(Loc
,
4572 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4573 Attribute_Name
=> Name_Pos
,
4574 Expressions
=> New_List
(
4575 Make_Attribute_Reference
(Loc
,
4576 Prefix
=> Duplicate_Subexpr
(Pref
),
4577 Attribute_Name
=> Name_Last
,
4579 New_Copy_List
(Exprs
)))),
4582 Make_Attribute_Reference
(Loc
,
4583 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4584 Attribute_Name
=> Name_Pos
,
4585 Expressions
=> New_List
(
4586 Make_Attribute_Reference
(Loc
,
4588 Duplicate_Subexpr_No_Checks
(Pref
),
4589 Attribute_Name
=> Name_First
,
4591 New_Copy_List
(Exprs
)))))))));
4593 Analyze_And_Resolve
(N
, Typ
);
4597 -- Otherwise leave it to the back end
4600 Apply_Universal_Integer_Attribute_Checks
(N
);
4604 -- Attribute Loop_Entry is replaced with a reference to a constant value
4605 -- which captures the prefix at the entry point of the related loop. The
4606 -- loop itself may be transformed into a conditional block.
4608 when Attribute_Loop_Entry
=>
4609 Expand_Loop_Entry_Attribute
(N
);
4615 -- Transforms 'Machine into a call to the floating-point attribute
4616 -- function Machine in Fat_xxx (where xxx is the root type).
4617 -- Expansion is avoided for cases the back end can handle directly.
4619 when Attribute_Machine
=>
4620 if not Is_Inline_Floating_Point_Attribute
(N
) then
4621 Expand_Fpt_Attribute_R
(N
);
4624 ----------------------
4625 -- Machine_Rounding --
4626 ----------------------
4628 -- Transforms 'Machine_Rounding into a call to the floating-point
4629 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4630 -- type). Expansion is avoided for cases the back end can handle
4633 when Attribute_Machine_Rounding
=>
4634 if not Is_Inline_Floating_Point_Attribute
(N
) then
4635 Expand_Fpt_Attribute_R
(N
);
4642 -- Machine_Size is equivalent to Object_Size, so transform it into
4643 -- Object_Size and that way the back end never sees Machine_Size.
4645 when Attribute_Machine_Size
=>
4647 Make_Attribute_Reference
(Loc
,
4648 Prefix
=> Prefix
(N
),
4649 Attribute_Name
=> Name_Object_Size
));
4651 Analyze_And_Resolve
(N
, Typ
);
4657 -- The only case that can get this far is the dynamic case of the old
4658 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4665 -- ityp (System.Mantissa.Mantissa_Value
4666 -- (Integer'Integer_Value (typ'First),
4667 -- Integer'Integer_Value (typ'Last)));
4669 when Attribute_Mantissa
=>
4672 Make_Function_Call
(Loc
,
4674 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4676 Parameter_Associations
=> New_List
(
4677 Make_Attribute_Reference
(Loc
,
4678 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4679 Attribute_Name
=> Name_Integer_Value
,
4680 Expressions
=> New_List
(
4681 Make_Attribute_Reference
(Loc
,
4682 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4683 Attribute_Name
=> Name_First
))),
4685 Make_Attribute_Reference
(Loc
,
4686 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4687 Attribute_Name
=> Name_Integer_Value
,
4688 Expressions
=> New_List
(
4689 Make_Attribute_Reference
(Loc
,
4690 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4691 Attribute_Name
=> Name_Last
)))))));
4693 Analyze_And_Resolve
(N
, Typ
);
4699 when Attribute_Max
=>
4700 Expand_Min_Max_Attribute
(N
);
4702 ----------------------------------
4703 -- Max_Size_In_Storage_Elements --
4704 ----------------------------------
4706 when Attribute_Max_Size_In_Storage_Elements
=> declare
4707 Typ
: constant Entity_Id
:= Etype
(N
);
4710 -- If the prefix is X'Class, we transform it into a direct reference
4711 -- to the class-wide type, because the back end must not see a 'Class
4712 -- reference. See also 'Size.
4714 if Is_Entity_Name
(Pref
)
4715 and then Is_Class_Wide_Type
(Entity
(Pref
))
4717 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4721 -- Heap-allocated controlled objects contain two extra pointers which
4722 -- are not part of the actual type. Transform the attribute reference
4723 -- into a runtime expression to add the size of the hidden header.
4725 if Needs_Finalization
(Ptyp
) and then not Header_Size_Added
(N
) then
4726 Set_Header_Size_Added
(N
);
4729 -- P'Max_Size_In_Storage_Elements +
4730 -- Typ (Header_Size_With_Padding (Ptyp'Alignment))
4734 Left_Opnd
=> Relocate_Node
(N
),
4737 Make_Function_Call
(Loc
,
4740 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4742 Parameter_Associations
=> New_List
(
4743 Make_Attribute_Reference
(Loc
,
4745 New_Occurrence_Of
(Ptyp
, Loc
),
4746 Attribute_Name
=> Name_Alignment
))))));
4748 Analyze_And_Resolve
(N
, Typ
);
4752 -- In the other cases apply the required checks
4754 Apply_Universal_Integer_Attribute_Checks
(N
);
4757 --------------------
4758 -- Mechanism_Code --
4759 --------------------
4761 when Attribute_Mechanism_Code
=>
4763 -- We must replace the prefix in the renamed case
4765 if Is_Entity_Name
(Pref
)
4766 and then Present
(Alias
(Entity
(Pref
)))
4768 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4775 when Attribute_Min
=>
4776 Expand_Min_Max_Attribute
(N
);
4782 when Attribute_Mod
=> Mod_Case
: declare
4783 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4784 Hi
: constant Node_Id
:= Type_High_Bound
(Base_Type
(Etype
(Arg
)));
4785 Modv
: constant Uint
:= Modulus
(Btyp
);
4789 -- This is not so simple. The issue is what type to use for the
4790 -- computation of the modular value. In addition we need to use
4791 -- the base type as above to retrieve a static bound for the
4792 -- comparisons that follow.
4794 -- The easy case is when the modulus value is within the bounds
4795 -- of the signed integer type of the argument. In this case we can
4796 -- just do the computation in that signed integer type, and then
4797 -- do an ordinary conversion to the target type.
4799 if Modv
<= Expr_Value
(Hi
) then
4804 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4806 -- Here we know that the modulus is larger than type'Last of the
4807 -- integer type. There are two cases to consider:
4809 -- a) The integer value is non-negative. In this case, it is
4810 -- returned as the result (since it is less than the modulus).
4812 -- b) The integer value is negative. In this case, we know that the
4813 -- result is modulus + value, where the value might be as small as
4814 -- -modulus. The trouble is what type do we use to do the subtract.
4815 -- No type will do, since modulus can be as big as 2**128, and no
4816 -- integer type accommodates this value. Let's do bit of algebra
4819 -- = modulus - (-value)
4820 -- = (modulus - 1) - (-value - 1)
4822 -- Now modulus - 1 is certainly in range of the modular type.
4823 -- -value is in the range 1 .. modulus, so -value -1 is in the
4824 -- range 0 .. modulus-1 which is in range of the modular type.
4825 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4826 -- which we can compute using the integer base type.
4828 -- Once this is done we analyze the if expression without range
4829 -- checks, because we know everything is in range, and we want
4830 -- to prevent spurious warnings on either branch.
4834 Make_If_Expression
(Loc
,
4835 Expressions
=> New_List
(
4837 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4838 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4841 Duplicate_Subexpr_No_Checks
(Arg
)),
4843 Make_Op_Subtract
(Loc
,
4845 Make_Integer_Literal
(Loc
,
4846 Intval
=> Modv
- 1),
4852 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4854 Make_Integer_Literal
(Loc
,
4855 Intval
=> 1))))))));
4859 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4866 -- Transforms 'Model into a call to the floating-point attribute
4867 -- function Model in Fat_xxx (where xxx is the root type).
4868 -- Expansion is avoided for cases the back end can handle directly.
4870 when Attribute_Model
=>
4871 if not Is_Inline_Floating_Point_Attribute
(N
) then
4872 Expand_Fpt_Attribute_R
(N
);
4879 -- The processing for Object_Size shares the processing for Size
4885 when Attribute_Old
=> Old
: declare
4886 Typ
: constant Entity_Id
:= Etype
(N
);
4887 CW_Temp
: Entity_Id
;
4894 use Old_Attr_Util
.Conditional_Evaluation
;
4895 use Old_Attr_Util
.Indirect_Temps
;
4897 -- Generating C code we don't need to expand this attribute when
4898 -- we are analyzing the internally built nested postconditions
4899 -- procedure since it will be expanded inline (and later it will
4900 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4901 -- performed in such case then the compiler generates unreferenced
4902 -- extra temporaries.
4904 if Modify_Tree_For_C
4905 and then Chars
(Current_Scope
) = Name_uPostconditions
4910 -- Climb the parent chain looking for subprogram _Postconditions
4913 while Present
(Subp
) loop
4914 exit when Nkind
(Subp
) = N_Subprogram_Body
4915 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4917 -- If assertions are disabled, no need to create the declaration
4918 -- that preserves the value. The postcondition pragma in which
4919 -- 'Old appears will be checked or disabled according to the
4920 -- current policy in effect.
4922 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4926 Subp
:= Parent
(Subp
);
4929 -- 'Old can only appear in a postcondition, the generated body of
4930 -- _Postconditions must be in the tree (or inlined if we are
4931 -- generating C code).
4935 or else (Modify_Tree_For_C
and then In_Inlined_Body
));
4937 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4939 -- Set the entity kind now in order to mark the temporary as a
4940 -- handler of attribute 'Old's prefix.
4942 Mutate_Ekind
(Temp
, E_Constant
);
4943 Set_Stores_Attribute_Old_Prefix
(Temp
);
4945 -- Push the scope of the related subprogram where _Postcondition
4946 -- resides as this ensures that the object will be analyzed in the
4949 if Present
(Subp
) then
4950 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4952 -- No need to push the scope when generating C code since the
4953 -- _Postcondition procedure has been inlined.
4955 else pragma Assert
(Modify_Tree_For_C
);
4956 pragma Assert
(In_Inlined_Body
);
4960 -- Locate the insertion place of the internal temporary that saves
4963 if Present
(Subp
) then
4966 -- Generating C, the postcondition procedure has been inlined and the
4967 -- temporary is added before the first declaration of the enclosing
4970 else pragma Assert
(Modify_Tree_For_C
);
4972 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
4973 Ins_Nod
:= Parent
(Ins_Nod
);
4976 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
4979 if Eligible_For_Conditional_Evaluation
(N
) then
4981 Eval_Stmts
: constant List_Id
:= New_List
;
4983 procedure Append_For_Indirect_Temp
4984 (N
: Node_Id
; Is_Eval_Stmt
: Boolean);
4985 -- Append either a declaration (which is to be elaborated
4986 -- unconditionally) or an evaluation statement (which is
4987 -- to be executed conditionally).
4989 -------------------------------
4990 -- Append_For_Indirect_Temp --
4991 -------------------------------
4993 procedure Append_For_Indirect_Temp
4994 (N
: Node_Id
; Is_Eval_Stmt
: Boolean)
4997 if Is_Eval_Stmt
then
4998 Append_To
(Eval_Stmts
, N
);
5000 Insert_Before_And_Analyze
(Ins_Nod
, N
);
5002 end Append_For_Indirect_Temp
;
5004 procedure Declare_Indirect_Temporary
is new
5005 Declare_Indirect_Temp
5006 (Append_Item
=> Append_For_Indirect_Temp
);
5008 Declare_Indirect_Temporary
5009 (Attr_Prefix
=> Pref
, Indirect_Temp
=> Temp
);
5011 Insert_Before_And_Analyze
(
5015 Condition
=> Conditional_Evaluation_Condition
(N
),
5016 Then_Statements
=> Eval_Stmts
));
5018 Rewrite
(N
, Indirect_Temp_Value
5020 Typ
=> Etype
(Pref
),
5023 if Present
(Subp
) then
5029 -- Preserve the tag of the prefix by offering a specific view of the
5030 -- class-wide version of the prefix.
5032 elsif Is_Tagged_Type
(Typ
) then
5035 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
5037 CW_Temp
:= Make_Temporary
(Loc
, 'T');
5038 CW_Typ
:= Class_Wide_Type
(Typ
);
5041 Make_Object_Declaration
(Loc
,
5042 Defining_Identifier
=> CW_Temp
,
5043 Constant_Present
=> True,
5044 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
5046 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
5048 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5051 -- Temp : Typ renames Typ (CW_Temp);
5053 Insert_Before_And_Analyze
(Ins_Nod
,
5054 Make_Object_Renaming_Declaration
(Loc
,
5055 Defining_Identifier
=> Temp
,
5056 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5058 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
5060 Set_Stores_Attribute_Old_Prefix
(CW_Temp
);
5066 -- Temp : constant Typ := Pref;
5069 Make_Object_Declaration
(Loc
,
5070 Defining_Identifier
=> Temp
,
5071 Constant_Present
=> True,
5072 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5073 Expression
=> Relocate_Node
(Pref
));
5075 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5079 if Present
(Subp
) then
5083 -- Ensure that the prefix of attribute 'Old is valid. The check must
5084 -- be inserted after the expansion of the attribute has taken place
5085 -- to reflect the new placement of the prefix.
5087 if Validity_Checks_On
and then Validity_Check_Operands
then
5088 Ensure_Valid
(Expression
(Decl
));
5091 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5094 ----------------------
5095 -- Overlaps_Storage --
5096 ----------------------
5098 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
5099 Loc
: constant Source_Ptr
:= Sloc
(N
);
5100 X
: constant Node_Id
:= Prefix
(N
);
5101 Y
: constant Node_Id
:= First
(Expressions
(N
));
5105 X_Addr
, Y_Addr
: Node_Id
;
5107 -- The expressions for their integer addresses
5109 X_Size
, Y_Size
: Node_Id
;
5111 -- The expressions for their sizes
5116 -- Attribute expands into:
5118 -- (if X'Size = 0 or else Y'Size = 0 then
5121 -- (if X'Address <= Y'Address then
5122 -- (X'Address + X'Size - 1) >= Y'Address
5124 -- (Y'Address + Y'Size - 1) >= X'Address))
5126 -- with the proper address operations. We convert addresses to
5127 -- integer addresses to use predefined arithmetic. The size is
5128 -- expressed in storage units. We add copies of X_Addr and Y_Addr
5129 -- to prevent the appearance of the same node in two places in
5133 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5134 Make_Attribute_Reference
(Loc
,
5135 Attribute_Name
=> Name_Address
,
5136 Prefix
=> New_Copy_Tree
(X
)));
5139 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5140 Make_Attribute_Reference
(Loc
,
5141 Attribute_Name
=> Name_Address
,
5142 Prefix
=> New_Copy_Tree
(Y
)));
5145 Make_Op_Divide
(Loc
,
5147 Make_Attribute_Reference
(Loc
,
5148 Attribute_Name
=> Name_Size
,
5149 Prefix
=> New_Copy_Tree
(X
)),
5151 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5154 Make_Op_Divide
(Loc
,
5156 Make_Attribute_Reference
(Loc
,
5157 Attribute_Name
=> Name_Size
,
5158 Prefix
=> New_Copy_Tree
(Y
)),
5160 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5164 Left_Opnd
=> X_Addr
,
5165 Right_Opnd
=> Y_Addr
);
5167 -- Perform the rewriting
5170 Make_If_Expression
(Loc
, New_List
(
5172 -- Generate a check for zero-sized things like a null record with
5173 -- size zero or an array with zero length since they have no
5174 -- opportunity of overlapping.
5176 -- Without this check, a zero-sized object can trigger a false
5177 -- runtime result if it's compared against another object in
5178 -- its declarative region, due to the zero-sized object having
5179 -- the same address.
5185 Make_Attribute_Reference
(Loc
,
5186 Attribute_Name
=> Name_Size
,
5187 Prefix
=> New_Copy_Tree
(X
)),
5188 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5192 Make_Attribute_Reference
(Loc
,
5193 Attribute_Name
=> Name_Size
,
5194 Prefix
=> New_Copy_Tree
(Y
)),
5195 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))),
5197 New_Occurrence_Of
(Standard_False
, Loc
),
5199 -- Non-zero-size overlap check
5201 Make_If_Expression
(Loc
, New_List
(
5207 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
5209 Make_Op_Subtract
(Loc
,
5210 Left_Opnd
=> X_Size
,
5211 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5212 Right_Opnd
=> Y_Addr
),
5217 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
5219 Make_Op_Subtract
(Loc
,
5220 Left_Opnd
=> Y_Size
,
5221 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5222 Right_Opnd
=> X_Addr
))))));
5224 Analyze_And_Resolve
(N
, Standard_Boolean
);
5225 end Overlaps_Storage
;
5231 when Attribute_Output
=> Output
: declare
5232 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5233 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5241 -- If no underlying type, we have an error that will be diagnosed
5242 -- elsewhere, so here we just completely ignore the expansion.
5248 -- Stream operations can appear in user code even if the restriction
5249 -- No_Streams is active (for example, when instantiating a predefined
5250 -- container). In that case rewrite the attribute as a Raise to
5251 -- prevent any run-time use.
5253 if Restriction_Active
(No_Streams
) then
5255 Make_Raise_Program_Error
(Sloc
(N
),
5256 Reason
=> PE_Stream_Operation_Not_Allowed
));
5257 Set_Etype
(N
, Standard_Void_Type
);
5261 -- If TSS for Output is present, just call it
5263 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
5265 if Present
(Pname
) then
5269 -- If there is a Stream_Convert pragma, use it, we rewrite
5271 -- sourcetyp'Output (stream, Item)
5275 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5277 -- where strmwrite is the given Write function that converts an
5278 -- argument of type sourcetyp or a type acctyp, from which it is
5279 -- derived to type strmtyp. The conversion to acttyp is required
5280 -- for the derived case.
5282 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5284 if Present
(Prag
) then
5286 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
5287 Wfunc
:= Entity
(Expression
(Arg3
));
5290 Make_Attribute_Reference
(Loc
,
5291 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
5292 Attribute_Name
=> Name_Output
,
5293 Expressions
=> New_List
(
5294 Relocate_Node
(First
(Exprs
)),
5295 Make_Function_Call
(Loc
,
5296 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
5297 Parameter_Associations
=> New_List
(
5298 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
5299 Relocate_Node
(Next
(First
(Exprs
)))))))));
5306 elsif Default_Streaming_Unavailable
(U_Type
) then
5307 -- Do the same thing here as is done above in the
5308 -- case where a No_Streams restriction is active.
5311 Make_Raise_Program_Error
(Sloc
(N
),
5312 Reason
=> PE_Stream_Operation_Not_Allowed
));
5313 Set_Etype
(N
, Standard_Void_Type
);
5316 -- For elementary types, we call the W_xxx routine directly. Note
5317 -- that the effect of Write and Output is identical for the case
5318 -- of an elementary type (there are no discriminants or bounds).
5320 elsif Is_Elementary_Type
(U_Type
) then
5322 -- A special case arises if we have a defined _Write routine,
5323 -- since in this case we are required to call this routine.
5325 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Write
)) then
5326 Build_Record_Or_Elementary_Output_Procedure
5327 (Loc
, P_Type
, Decl
, Pname
);
5328 Insert_Action
(N
, Decl
);
5330 -- For normal cases, we call the W_xxx routine directly
5333 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
5340 elsif Is_Array_Type
(U_Type
) then
5341 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
5342 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
5344 -- Class-wide case, first output external tag, then dispatch
5345 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5347 elsif Is_Class_Wide_Type
(P_Type
) then
5349 -- No need to do anything else compiling under restriction
5350 -- No_Dispatching_Calls. During the semantic analysis we
5351 -- already notified such violation.
5353 if Restriction_Active
(No_Dispatching_Calls
) then
5358 Strm
: constant Node_Id
:= First
(Exprs
);
5359 Item
: constant Node_Id
:= Next
(Strm
);
5362 -- Ada 2005 (AI-344): Check that the accessibility level
5363 -- of the type of the output object is not deeper than
5364 -- that of the attribute's prefix type.
5366 -- if Get_Access_Level (Item'Tag)
5367 -- /= Get_Access_Level (P_Type'Tag)
5372 -- String'Output (Strm, External_Tag (Item'Tag));
5374 -- We cannot figure out a practical way to implement this
5375 -- accessibility check on virtual machines, so we omit it.
5377 if Ada_Version
>= Ada_2005
5378 and then Tagged_Type_Expansion
5381 Make_Implicit_If_Statement
(N
,
5385 Build_Get_Access_Level
(Loc
,
5386 Make_Attribute_Reference
(Loc
,
5389 Duplicate_Subexpr
(Item
,
5391 Attribute_Name
=> Name_Tag
)),
5394 Make_Integer_Literal
(Loc
,
5395 Type_Access_Level
(P_Type
))),
5398 New_List
(Make_Raise_Statement
(Loc
,
5400 RTE
(RE_Tag_Error
), Loc
)))));
5404 Make_Attribute_Reference
(Loc
,
5405 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
5406 Attribute_Name
=> Name_Output
,
5407 Expressions
=> New_List
(
5408 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
5409 Make_Function_Call
(Loc
,
5411 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
5412 Parameter_Associations
=> New_List
(
5413 Make_Attribute_Reference
(Loc
,
5416 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
5417 Attribute_Name
=> Name_Tag
))))));
5420 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5422 -- Tagged type case, use the primitive Output function
5424 elsif Is_Tagged_Type
(U_Type
) then
5425 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5427 -- All other record type cases, including protected records.
5428 -- The latter only arise for expander generated code for
5429 -- handling shared passive partition access.
5433 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5435 -- Ada 2005 (AI-216): Program_Error is raised when executing
5436 -- the default implementation of the Output attribute of an
5437 -- unchecked union type if the type lacks default discriminant
5440 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5442 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5445 Make_Raise_Program_Error
(Loc
,
5446 Reason
=> PE_Unchecked_Union_Restriction
));
5447 Set_Etype
(N
, Standard_Void_Type
);
5451 Build_Record_Or_Elementary_Output_Procedure
5452 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
5453 Insert_Action
(N
, Decl
);
5457 -- If we fall through, Pname is the name of the procedure to call
5459 Rewrite_Attribute_Proc_Call
(Pname
);
5466 -- For enumeration types, with a non-standard representation we generate
5467 -- a call to the _Rep_To_Pos function created when the type was frozen.
5468 -- The call has the form:
5470 -- _rep_to_pos (expr, flag)
5472 -- The parameter flag is True if range checks are enabled, causing
5473 -- Program_Error to be raised if the expression has an invalid
5474 -- representation, and False if range checks are suppressed.
5476 -- For enumeration types with a standard representation, Pos can be
5477 -- rewritten as a simple conversion with Conversion_OK set.
5479 -- For integer types, Pos is equivalent to a simple integer conversion
5480 -- and we rewrite it as such.
5482 when Attribute_Pos
=> Pos
: declare
5483 Expr
: constant Node_Id
:= First
(Exprs
);
5484 Etyp
: Entity_Id
:= Base_Type
(Ptyp
);
5487 -- Deal with zero/non-zero boolean values
5489 if Is_Boolean_Type
(Etyp
) then
5490 Adjust_Condition
(Expr
);
5491 Etyp
:= Standard_Boolean
;
5492 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5495 -- Case of enumeration type
5497 if Is_Enumeration_Type
(Etyp
) then
5499 -- Non-standard enumeration type (generate call)
5501 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5502 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5505 Make_Function_Call
(Loc
,
5507 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5508 Parameter_Associations
=> Exprs
)));
5510 -- Standard enumeration type (replace by conversion)
5512 -- This is simply a direct conversion from the enumeration type to
5513 -- the target integer type, which is treated by the back end as a
5514 -- normal integer conversion, treating the enumeration type as an
5515 -- integer, which is exactly what we want. We set Conversion_OK to
5516 -- make sure that the analyzer does not complain about what might
5517 -- be an illegal conversion.
5519 -- However the target type is universal integer in most cases,
5520 -- which is a very large type, so we first convert to a small
5521 -- signed integer type in order not to lose the size information.
5524 Rewrite
(N
, OK_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
5525 Convert_To_And_Rewrite
(Typ
, N
);
5529 -- Deal with integer types (replace by conversion)
5532 Rewrite
(N
, Convert_To
(Typ
, Expr
));
5535 Analyze_And_Resolve
(N
, Typ
);
5542 -- We leave the computation up to the back end, since we don't know what
5543 -- layout will be chosen if no component clause was specified.
5545 when Attribute_Position
=>
5546 Apply_Universal_Integer_Attribute_Checks
(N
);
5552 -- 1. Deal with enumeration types with holes.
5553 -- 2. For floating-point, generate call to attribute function.
5554 -- 3. For other cases, deal with constraint checking.
5556 when Attribute_Pred
=> Pred
: declare
5557 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5560 -- For enumeration types with non-standard representations, we
5561 -- expand typ'Pred (x) into:
5563 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5565 -- if the representation is non-contiguous, and just x - 1 if it is
5566 -- after having dealt with constraint checking.
5568 if Is_Enumeration_Type
(Etyp
)
5569 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5571 if Has_Contiguous_Rep
(Etyp
) then
5572 if not Range_Checks_Suppressed
(Ptyp
) then
5573 Set_Do_Range_Check
(First
(Exprs
), False);
5574 Expand_Pred_Succ_Attribute
(N
);
5578 Unchecked_Convert_To
(Etyp
,
5579 Make_Op_Subtract
(Loc
,
5581 Unchecked_Convert_To
(
5583 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
5586 Make_Integer_Literal
(Loc
, 1))));
5589 -- Add Boolean parameter True, to request program error if
5590 -- we have a bad representation on our hands. If checks are
5591 -- suppressed, then add False instead
5593 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5595 Make_Indexed_Component
(Loc
,
5598 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5599 Expressions
=> New_List
(
5600 Make_Op_Subtract
(Loc
,
5602 Make_Function_Call
(Loc
,
5605 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5606 Parameter_Associations
=> Exprs
),
5607 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5610 -- Suppress checks since they have all been done above
5612 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
5614 -- For floating-point, we transform 'Pred into a call to the Pred
5615 -- floating-point attribute function in Fat_xxx (xxx is root type).
5616 -- Note that this function takes care of the overflow case.
5618 elsif Is_Floating_Point_Type
(Ptyp
) then
5619 Expand_Fpt_Attribute_R
(N
);
5620 Analyze_And_Resolve
(N
, Typ
);
5622 -- For modular types, nothing to do (no overflow, since wraps)
5624 elsif Is_Modular_Integer_Type
(Ptyp
) then
5627 -- For other types, if argument is marked as needing a range check or
5628 -- overflow checking is enabled, we must generate a check.
5630 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5631 or else Do_Range_Check
(First
(Exprs
))
5633 Set_Do_Range_Check
(First
(Exprs
), False);
5634 Expand_Pred_Succ_Attribute
(N
);
5638 ----------------------------------
5639 -- Preelaborable_Initialization --
5640 ----------------------------------
5642 when Attribute_Preelaborable_Initialization
=>
5644 -- This attribute should already be folded during analysis, but if
5645 -- for some reason it hasn't been, we fold it now.
5650 (Boolean'Pos (Has_Preelaborable_Initialization
(Ptyp
))),
5657 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5659 -- We rewrite X'Priority as the following run-time call:
5661 -- Get_Ceiling (X._Object)
5663 -- Note that although X'Priority is notionally an object, it is quite
5664 -- deliberately not defined as an aliased object in the RM. This means
5665 -- that it works fine to rewrite it as a call, without having to worry
5666 -- about complications that would other arise from X'Priority'Access,
5667 -- which is illegal, because of the lack of aliasing.
5669 when Attribute_Priority
=> Priority
: declare
5671 Conctyp
: Entity_Id
;
5672 New_Itype
: Entity_Id
;
5673 Object_Parm
: Node_Id
;
5675 RT_Subprg_Name
: Node_Id
;
5678 -- Look for the enclosing concurrent type
5680 Conctyp
:= Current_Scope
;
5681 while not Is_Concurrent_Type
(Conctyp
) loop
5682 Conctyp
:= Scope
(Conctyp
);
5685 pragma Assert
(Is_Protected_Type
(Conctyp
));
5687 -- Generate the actual of the call
5689 Subprg
:= Current_Scope
;
5690 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5691 Subprg
:= Scope
(Subprg
);
5694 -- Use of 'Priority inside protected entries and barriers (in both
5695 -- cases the type of the first formal of their expanded subprogram
5698 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5701 -- In the expansion of protected entries the type of the first
5702 -- formal of the Protected_Body_Subprogram is an Address. In order
5703 -- to reference the _object component we generate:
5705 -- type T is access p__ptTV;
5708 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5709 Set_Etype
(New_Itype
, New_Itype
);
5710 Set_Directly_Designated_Type
(New_Itype
,
5711 Corresponding_Record_Type
(Conctyp
));
5712 Freeze_Itype
(New_Itype
, N
);
5715 -- T!(O)._object'unchecked_access
5718 Make_Attribute_Reference
(Loc
,
5720 Make_Selected_Component
(Loc
,
5722 Unchecked_Convert_To
(New_Itype
,
5724 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5726 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5727 Attribute_Name
=> Name_Unchecked_Access
);
5729 -- Use of 'Priority inside a protected subprogram
5733 Make_Attribute_Reference
(Loc
,
5735 Make_Selected_Component
(Loc
,
5738 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5740 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5741 Attribute_Name
=> Name_Unchecked_Access
);
5744 -- Select the appropriate run-time subprogram
5746 if Number_Entries
(Conctyp
) = 0 then
5747 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5749 RT_Subprg_Name
:= New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5753 Make_Function_Call
(Loc
,
5754 Name
=> RT_Subprg_Name
,
5755 Parameter_Associations
=> New_List
(Object_Parm
));
5759 -- Avoid the generation of extra checks on the pointer to the
5760 -- protected object.
5762 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5769 when Attribute_Put_Image
=> Put_Image
: declare
5771 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Pref
));
5776 -- If no underlying type, we have an error that will be diagnosed
5777 -- elsewhere, so here we just completely ignore the expansion.
5783 -- If there is a TSS for Put_Image, just call it. This is true for
5784 -- tagged types (if enabled) and if there is a user-specified
5787 Pname
:= TSS
(U_Type
, TSS_Put_Image
);
5789 if Is_Tagged_Type
(U_Type
) and then Is_Derived_Type
(U_Type
) then
5790 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5792 Pname
:= Find_Inherited_TSS
(U_Type
, TSS_Put_Image
);
5797 -- If Put_Image is disabled, call the "unknown" version
5799 if not Enable_Put_Image
(U_Type
) then
5800 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5804 -- For elementary types, we call the routine in System.Put_Images
5807 elsif Is_Elementary_Type
(U_Type
) then
5808 Rewrite
(N
, Build_Elementary_Put_Image_Call
(N
));
5812 elsif Is_Standard_String_Type
(U_Type
) then
5813 Rewrite
(N
, Build_String_Put_Image_Call
(N
));
5817 elsif Is_Array_Type
(U_Type
) then
5818 Build_Array_Put_Image_Procedure
(N
, U_Type
, Decl
, Pname
);
5819 Insert_Action
(N
, Decl
);
5821 -- Tagged type case, use the primitive Put_Image function. Note
5822 -- that this will dispatch in the class-wide case which is what we
5825 elsif Is_Tagged_Type
(U_Type
) then
5826 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5828 -- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
5829 -- because we might be deriving from a predefined type, which
5830 -- currently has Enable_Put_Image False.
5833 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5838 elsif Is_Protected_Type
(U_Type
) then
5839 Rewrite
(N
, Build_Protected_Put_Image_Call
(N
));
5843 elsif Is_Task_Type
(U_Type
) then
5844 Rewrite
(N
, Build_Task_Put_Image_Call
(N
));
5848 -- All other record type cases
5851 pragma Assert
(Is_Record_Type
(U_Type
));
5852 Build_Record_Put_Image_Procedure
5853 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5854 Insert_Action
(N
, Decl
);
5858 -- If we fall through, Pname is the procedure to be called
5860 Rewrite_Attribute_Proc_Call
(Pname
);
5867 when Attribute_Range_Length
=>
5869 -- The only special processing required is for the case where
5870 -- Range_Length is applied to an enumeration type with holes.
5871 -- In this case we transform
5877 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5879 -- So that the result reflects the proper Pos values instead
5880 -- of the underlying representations.
5882 if Is_Enumeration_Type
(Ptyp
)
5883 and then Has_Non_Standard_Rep
(Ptyp
)
5888 Make_Op_Subtract
(Loc
,
5890 Make_Attribute_Reference
(Loc
,
5891 Attribute_Name
=> Name_Pos
,
5892 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5893 Expressions
=> New_List
(
5894 Make_Attribute_Reference
(Loc
,
5895 Attribute_Name
=> Name_Last
,
5897 New_Occurrence_Of
(Ptyp
, Loc
)))),
5900 Make_Attribute_Reference
(Loc
,
5901 Attribute_Name
=> Name_Pos
,
5902 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5903 Expressions
=> New_List
(
5904 Make_Attribute_Reference
(Loc
,
5905 Attribute_Name
=> Name_First
,
5907 New_Occurrence_Of
(Ptyp
, Loc
))))),
5909 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5911 Analyze_And_Resolve
(N
, Typ
);
5913 -- For all other cases, the attribute is handled by the back end, but
5914 -- we need to deal with the case of the range check on a universal
5918 Apply_Universal_Integer_Attribute_Checks
(N
);
5925 when Attribute_Reduce
=>
5927 Loc
: constant Source_Ptr
:= Sloc
(N
);
5928 E1
: constant Node_Id
:= First
(Expressions
(N
));
5929 E2
: constant Node_Id
:= Next
(E1
);
5930 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
5931 Typ
: constant Entity_Id
:= Etype
(N
);
5936 function Build_Stat
(Comp
: Node_Id
) return Node_Id
;
5937 -- The reducer can be a function, a procedure whose first
5938 -- parameter is in-out, or an attribute that is a function,
5939 -- which (for now) can only be Min/Max. This subprogram
5940 -- builds the corresponding computation for the generated loop.
5946 function Build_Stat
(Comp
: Node_Id
) return Node_Id
is
5948 if Nkind
(E1
) = N_Attribute_Reference
then
5949 Stat
:= Make_Assignment_Statement
(Loc
,
5950 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
5951 Expression
=> Make_Attribute_Reference
(Loc
,
5952 Attribute_Name
=> Attribute_Name
(E1
),
5953 Prefix
=> New_Copy
(Prefix
(E1
)),
5954 Expressions
=> New_List
(
5955 New_Occurrence_Of
(Bnn
, Loc
),
5958 elsif Ekind
(Entity
(E1
)) = E_Procedure
then
5959 Stat
:= Make_Procedure_Call_Statement
(Loc
,
5960 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
5961 Parameter_Associations
=> New_List
(
5962 New_Occurrence_Of
(Bnn
, Loc
),
5965 Stat
:= Make_Assignment_Statement
(Loc
,
5966 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
5967 Expression
=> Make_Function_Call
(Loc
,
5968 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
5969 Parameter_Associations
=> New_List
(
5970 New_Occurrence_Of
(Bnn
, Loc
),
5977 -- If the prefix is an aggregate, its unique component is an
5978 -- Iterated_Element, and we create a loop out of its iterator.
5979 -- The iterated_component_association is parsed as a loop parameter
5980 -- specification with "in" or as a container iterator with "of".
5983 if Nkind
(Prefix
(N
)) = N_Aggregate
then
5985 Stream
: constant Node_Id
:=
5986 First
(Component_Associations
(Prefix
(N
)));
5987 Expr
: constant Node_Id
:= Expression
(Stream
);
5988 Id
: constant Node_Id
:= Defining_Identifier
(Stream
);
5989 It_Spec
: constant Node_Id
:=
5990 Iterator_Specification
(Stream
);
5995 -- Iteration may be given by an element iterator:
5997 if Nkind
(Stream
) = N_Iterated_Component_Association
5998 and then Present
(It_Spec
)
5999 and then Of_Present
(It_Spec
)
6002 Make_Iteration_Scheme
(Loc
,
6003 Iterator_Specification
=>
6004 Relocate_Node
(It_Spec
),
6005 Loop_Parameter_Specification
=> Empty
);
6008 Ch
:= First
(Discrete_Choices
(Stream
));
6010 Make_Iteration_Scheme
(Loc
,
6011 Iterator_Specification
=> Empty
,
6012 Loop_Parameter_Specification
=>
6013 Make_Loop_Parameter_Specification
(Loc
,
6014 Defining_Identifier
=> New_Copy
(Id
),
6015 Discrete_Subtype_Definition
=>
6016 Relocate_Node
(Ch
)));
6019 New_Loop
:= Make_Loop_Statement
(Loc
,
6020 Iteration_Scheme
=> Iter
,
6023 New_List
(Build_Stat
(Relocate_Node
(Expr
))));
6027 -- If the prefix is a name, we construct an element iterator
6028 -- over it. Its expansion will verify that it is an array or
6029 -- a container with the proper aspects.
6033 Elem
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
6037 Make_Iterator_Specification
(Loc
,
6038 Defining_Identifier
=> Elem
,
6039 Name
=> Relocate_Node
(Prefix
(N
)),
6040 Subtype_Indication
=> Empty
);
6041 Set_Of_Present
(Iter
);
6043 New_Loop
:= Make_Loop_Statement
(Loc
,
6045 Make_Iteration_Scheme
(Loc
,
6046 Iterator_Specification
=> Iter
,
6047 Loop_Parameter_Specification
=> Empty
),
6049 Statements
=> New_List
(
6050 Build_Stat
(New_Occurrence_Of
(Elem
, Loc
))));
6055 Make_Expression_With_Actions
(Loc
,
6056 Actions
=> New_List
(
6057 Make_Object_Declaration
(Loc
,
6058 Defining_Identifier
=> Bnn
,
6059 Object_Definition
=>
6060 New_Occurrence_Of
(Typ
, Loc
),
6061 Expression
=> Relocate_Node
(E2
)), New_Loop
),
6062 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
6063 Analyze_And_Resolve
(N
, Typ
);
6070 when Attribute_Read
=> Read
: declare
6071 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6072 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
6073 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6083 -- If no underlying type, we have an error that will be diagnosed
6084 -- elsewhere, so here we just completely ignore the expansion.
6090 -- Stream operations can appear in user code even if the restriction
6091 -- No_Streams is active (for example, when instantiating a predefined
6092 -- container). In that case rewrite the attribute as a Raise to
6093 -- prevent any run-time use.
6095 if Restriction_Active
(No_Streams
) then
6097 Make_Raise_Program_Error
(Sloc
(N
),
6098 Reason
=> PE_Stream_Operation_Not_Allowed
));
6099 Set_Etype
(N
, B_Type
);
6103 -- The simple case, if there is a TSS for Read, just call it
6105 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
6107 if Present
(Pname
) then
6111 -- If there is a Stream_Convert pragma, use it, we rewrite
6113 -- sourcetyp'Read (stream, Item)
6117 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
6119 -- where strmread is the given Read function that converts an
6120 -- argument of type strmtyp to type sourcetyp or a type from which
6121 -- it is derived. The conversion to sourcetyp is required in the
6124 -- A special case arises if Item is a type conversion in which
6125 -- case, we have to expand to:
6127 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
6129 -- where Itemx is the expression of the type conversion (i.e.
6130 -- the actual object), and typex is the type of Itemx.
6132 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6134 if Present
(Prag
) then
6135 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
6136 Rfunc
:= Entity
(Expression
(Arg2
));
6137 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6139 OK_Convert_To
(B_Type
,
6140 Make_Function_Call
(Loc
,
6141 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
6142 Parameter_Associations
=> New_List
(
6143 Make_Attribute_Reference
(Loc
,
6146 (Etype
(First_Formal
(Rfunc
)), Loc
),
6147 Attribute_Name
=> Name_Input
,
6148 Expressions
=> New_List
(
6149 Relocate_Node
(First
(Exprs
)))))));
6151 if Nkind
(Lhs
) = N_Type_Conversion
then
6152 Lhs
:= Expression
(Lhs
);
6153 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6157 Make_Assignment_Statement
(Loc
,
6159 Expression
=> Rhs
));
6160 Set_Assignment_OK
(Lhs
);
6166 elsif Default_Streaming_Unavailable
(U_Type
) then
6167 -- Do the same thing here as is done above in the
6168 -- case where a No_Streams restriction is active.
6171 Make_Raise_Program_Error
(Sloc
(N
),
6172 Reason
=> PE_Stream_Operation_Not_Allowed
));
6173 Set_Etype
(N
, B_Type
);
6176 -- For elementary types, we call the I_xxx routine using the first
6177 -- parameter and then assign the result into the second parameter.
6178 -- We set Assignment_OK to deal with the conversion case.
6180 elsif Is_Elementary_Type
(U_Type
) then
6186 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6187 Rhs
:= Build_Elementary_Input_Call
(N
);
6189 if Nkind
(Lhs
) = N_Type_Conversion
then
6190 Lhs
:= Expression
(Lhs
);
6191 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6194 Set_Assignment_OK
(Lhs
);
6197 Make_Assignment_Statement
(Loc
,
6199 Expression
=> Rhs
));
6207 elsif Is_Array_Type
(U_Type
) then
6208 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
6209 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
6211 -- Tagged type case, use the primitive Read function. Note that
6212 -- this will dispatch in the class-wide case which is what we want
6214 elsif Is_Tagged_Type
(U_Type
) then
6215 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
6217 -- All other record type cases, including protected records. The
6218 -- latter only arise for expander generated code for handling
6219 -- shared passive partition access.
6223 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
6225 -- Ada 2005 (AI-216): Program_Error is raised when executing
6226 -- the default implementation of the Read attribute of an
6227 -- Unchecked_Union type. We replace the attribute with a
6228 -- raise statement (rather than inserting it before) to handle
6229 -- properly the case of an unchecked union that is a record
6232 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
6234 Make_Raise_Program_Error
(Loc
,
6235 Reason
=> PE_Unchecked_Union_Restriction
));
6236 Set_Etype
(N
, B_Type
);
6240 if Has_Defaulted_Discriminants
(U_Type
) then
6241 Build_Mutable_Record_Read_Procedure
6242 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6244 Build_Record_Read_Procedure
6245 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6248 Insert_Action
(N
, Decl
);
6252 Rewrite_Attribute_Proc_Call
(Pname
);
6259 -- Ref is identical to To_Address, see To_Address for processing
6265 -- Transforms 'Remainder into a call to the floating-point attribute
6266 -- function Remainder in Fat_xxx (where xxx is the root type)
6268 when Attribute_Remainder
=>
6269 Expand_Fpt_Attribute_RR
(N
);
6275 -- Transform 'Result into reference to _Result formal. At the point
6276 -- where a legal 'Result attribute is expanded, we know that we are in
6277 -- the context of a _Postcondition function with a _Result parameter.
6279 when Attribute_Result
=>
6280 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
6281 Analyze_And_Resolve
(N
, Typ
);
6287 -- The handling of the Round attribute is delicate when the operand is
6288 -- universal fixed. In this case, the processing in Sem_Attr introduced
6289 -- a conversion to universal real, reflecting the semantics of Round,
6290 -- but we do not want anything to do with universal real at run time,
6291 -- since this corresponds to using floating-point arithmetic.
6293 -- What we have now is that the Etype of the Round attribute correctly
6294 -- indicates the final result type. The operand of the Round is the
6295 -- conversion to universal real, described above, and the operand of
6296 -- this conversion is the actual operand of Round, which may be the
6297 -- special case of a fixed point multiplication or division.
6299 -- The expander will expand first the operand of the conversion, then
6300 -- the conversion, and finally the round attribute itself, since we
6301 -- always work inside out. But we cannot simply process naively in this
6302 -- order. In the semantic world where universal fixed and real really
6303 -- exist and have infinite precision, there is no problem, but in the
6304 -- implementation world, where universal real is a floating-point type,
6305 -- we would get the wrong result.
6307 -- So the approach is as follows. When expanding a multiply or divide
6308 -- whose type is universal fixed, Fixup_Universal_Fixed_Operation will
6309 -- look up and skip the conversion to universal real if its parent is
6310 -- a Round attribute, taking information from this attribute node. In
6311 -- the other cases, Expand_N_Type_Conversion does the same by looking
6312 -- at its parent to see if it is a Round attribute, before calling the
6313 -- fixed-point expansion routine.
6315 -- This means that by the time we get to expanding the Round attribute
6316 -- itself, the Round is nothing more than a type conversion (and will
6317 -- often be a null type conversion), so we just replace it with the
6318 -- appropriate conversion operation.
6320 when Attribute_Round
=>
6321 if Etype
(First
(Exprs
)) = Etype
(N
) then
6322 Rewrite
(N
, Relocate_Node
(First
(Exprs
)));
6324 Rewrite
(N
, Convert_To
(Etype
(N
), First
(Exprs
)));
6325 Set_Rounded_Result
(N
);
6327 Analyze_And_Resolve
(N
);
6333 -- Transforms 'Rounding into a call to the floating-point attribute
6334 -- function Rounding in Fat_xxx (where xxx is the root type)
6335 -- Expansion is avoided for cases the back end can handle directly.
6337 when Attribute_Rounding
=>
6338 if not Is_Inline_Floating_Point_Attribute
(N
) then
6339 Expand_Fpt_Attribute_R
(N
);
6346 -- Transforms 'Scaling into a call to the floating-point attribute
6347 -- function Scaling in Fat_xxx (where xxx is the root type)
6349 when Attribute_Scaling
=>
6350 Expand_Fpt_Attribute_RI
(N
);
6352 ----------------------------------------
6353 -- Simple_Storage_Pool & Storage_Pool --
6354 ----------------------------------------
6356 when Attribute_Simple_Storage_Pool | Attribute_Storage_Pool
=>
6358 Make_Type_Conversion
(Loc
,
6359 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
6360 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
6361 Analyze_And_Resolve
(N
, Typ
);
6367 when Attribute_Object_Size
6369 | Attribute_Value_Size
6370 | Attribute_VADS_Size
6376 -- Processing for VADS_Size case. Note that this processing
6377 -- removes all traces of VADS_Size from the tree, and completes
6378 -- all required processing for VADS_Size by translating the
6379 -- attribute reference to an appropriate Size or Object_Size
6382 if Id
= Attribute_VADS_Size
6383 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
6385 -- If the size is specified, then we simply use the specified
6386 -- size. This applies to both types and objects. The size of an
6387 -- object can be specified in the following ways:
6389 -- An explicit size clause is given for an object
6390 -- A component size is specified for an indexed component
6391 -- A component clause is specified for a selected component
6392 -- The object is a component of a packed composite object
6394 -- If the size is specified, then VADS_Size of an object
6396 if (Is_Entity_Name
(Pref
)
6397 and then Present
(Size_Clause
(Entity
(Pref
))))
6399 (Nkind
(Pref
) = N_Component_Clause
6400 and then (Present
(Component_Clause
6401 (Entity
(Selector_Name
(Pref
))))
6402 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6404 (Nkind
(Pref
) = N_Indexed_Component
6405 and then (Known_Component_Size
(Etype
(Prefix
(Pref
)))
6406 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6408 Set_Attribute_Name
(N
, Name_Size
);
6410 -- Otherwise if we have an object rather than a type, then
6411 -- the VADS_Size attribute applies to the type of the object,
6412 -- rather than the object itself. This is one of the respects
6413 -- in which VADS_Size differs from Size.
6416 if (not Is_Entity_Name
(Pref
)
6417 or else not Is_Type
(Entity
(Pref
)))
6418 and then (Is_Scalar_Type
(Ptyp
)
6419 or else Is_Constrained
(Ptyp
))
6421 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
6424 -- For a scalar type for which no size was explicitly given,
6425 -- VADS_Size means Object_Size. This is the other respect in
6426 -- which VADS_Size differs from Size.
6428 if Is_Scalar_Type
(Ptyp
)
6429 and then No
(Size_Clause
(Ptyp
))
6431 Set_Attribute_Name
(N
, Name_Object_Size
);
6433 -- In all other cases, Size and VADS_Size are the same
6436 Set_Attribute_Name
(N
, Name_Size
);
6441 -- If the prefix is X'Class, transform it into a direct reference
6442 -- to the class-wide type, because the back end must not see a
6443 -- 'Class reference.
6445 if Is_Entity_Name
(Pref
)
6446 and then Is_Class_Wide_Type
(Entity
(Pref
))
6448 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
6451 -- For X'Size applied to an object of a class-wide type, transform
6452 -- X'Size into a call to the primitive operation _Size applied to
6455 elsif Is_Class_Wide_Type
(Ptyp
) then
6457 -- No need to do anything else compiling under restriction
6458 -- No_Dispatching_Calls. During the semantic analysis we
6459 -- already noted this restriction violation.
6461 if Restriction_Active
(No_Dispatching_Calls
) then
6466 Make_Function_Call
(Loc
,
6468 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
6469 Parameter_Associations
=> New_List
(Pref
));
6471 if Typ
/= Standard_Long_Long_Integer
then
6473 -- The context is a specific integer type with which the
6474 -- original attribute was compatible. The function has a
6475 -- specific type as well, so to preserve the compatibility
6476 -- we must convert explicitly.
6478 New_Node
:= Convert_To
(Typ
, New_Node
);
6481 Rewrite
(N
, New_Node
);
6482 Analyze_And_Resolve
(N
, Typ
);
6486 -- Call Expand_Size_Attribute to do the final part of the
6487 -- expansion which is shared with GNATprove expansion.
6489 Expand_Size_Attribute
(N
);
6496 when Attribute_Storage_Size
=> Storage_Size
: declare
6497 Alloc_Op
: Entity_Id
:= Empty
;
6501 -- Access type case, always go to the root type
6503 -- The case of access types results in a value of zero for the case
6504 -- where no storage size attribute clause has been given. If a
6505 -- storage size has been given, then the attribute is converted
6506 -- to a reference to the variable used to hold this value.
6508 if Is_Access_Type
(Ptyp
) then
6509 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
6512 Make_Attribute_Reference
(Loc
,
6513 Prefix
=> New_Occurrence_Of
6514 (Etype
(Storage_Size_Variable
(Root_Type
(Ptyp
))), Loc
),
6515 Attribute_Name
=> Name_Max
,
6516 Expressions
=> New_List
(
6517 Make_Integer_Literal
(Loc
, 0),
6519 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
6521 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
6523 -- If the access type is associated with a simple storage pool
6524 -- object, then attempt to locate the optional Storage_Size
6525 -- function of the simple storage pool type. If not found,
6526 -- then the result will default to zero.
6528 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
6529 Name_Simple_Storage_Pool_Type
))
6532 Pool_Type
: constant Entity_Id
:=
6533 Base_Type
(Etype
(Entity
(N
)));
6536 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
6537 while Present
(Alloc_Op
) loop
6538 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
6539 and then Present
(First_Formal
(Alloc_Op
))
6540 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
6545 Alloc_Op
:= Homonym
(Alloc_Op
);
6549 -- In the normal Storage_Pool case, retrieve the primitive
6550 -- function associated with the pool type.
6555 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
6556 Attribute_Name
(N
));
6559 -- If Storage_Size wasn't found (can only occur in the simple
6560 -- storage pool case), then simply use zero for the result.
6562 if not Present
(Alloc_Op
) then
6563 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6565 -- Otherwise, rewrite the allocator as a call to pool type's
6566 -- Storage_Size function.
6571 Make_Function_Call
(Loc
,
6573 New_Occurrence_Of
(Alloc_Op
, Loc
),
6575 Parameter_Associations
=> New_List
(
6577 (Associated_Storage_Pool
6578 (Root_Type
(Ptyp
)), Loc
)))));
6582 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6585 Analyze_And_Resolve
(N
, Typ
);
6587 -- For tasks, we retrieve the size directly from the TCB. The
6588 -- size may depend on a discriminant of the type, and therefore
6589 -- can be a per-object expression, so type-level information is
6590 -- not sufficient in general. There are four cases to consider:
6592 -- a) If the attribute appears within a task body, the designated
6593 -- TCB is obtained by a call to Self.
6595 -- b) If the prefix of the attribute is the name of a task object,
6596 -- the designated TCB is the one stored in the corresponding record.
6598 -- c) If the prefix is a task type, the size is obtained from the
6599 -- size variable created for each task type
6601 -- d) If no Storage_Size was specified for the type, there is no
6602 -- size variable, and the value is a system-specific default.
6605 if In_Open_Scopes
(Ptyp
) then
6607 -- Storage_Size (Self)
6611 Make_Function_Call
(Loc
,
6613 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6614 Parameter_Associations
=>
6616 Make_Function_Call
(Loc
,
6618 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6620 elsif not Is_Entity_Name
(Pref
)
6621 or else not Is_Type
(Entity
(Pref
))
6623 -- Storage_Size (Rec (Obj).Size)
6627 Make_Function_Call
(Loc
,
6629 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6630 Parameter_Associations
=>
6632 Make_Selected_Component
(Loc
,
6634 Unchecked_Convert_To
(
6635 Corresponding_Record_Type
(Ptyp
),
6636 New_Copy_Tree
(Pref
)),
6638 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6640 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6642 -- Static Storage_Size pragma given for type: retrieve value
6643 -- from its allocated storage variable.
6647 Make_Function_Call
(Loc
,
6648 Name
=> New_Occurrence_Of
(
6649 RTE
(RE_Adjust_Storage_Size
), Loc
),
6650 Parameter_Associations
=>
6653 Storage_Size_Variable
(Ptyp
), Loc
)))));
6655 -- Get system default
6659 Make_Function_Call
(Loc
,
6662 RTE
(RE_Default_Stack_Size
), Loc
))));
6665 Analyze_And_Resolve
(N
, Typ
);
6673 when Attribute_Stream_Size
=>
6675 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6676 Analyze_And_Resolve
(N
, Typ
);
6682 -- 1. Deal with enumeration types with holes.
6683 -- 2. For floating-point, generate call to attribute function.
6684 -- 3. For other cases, deal with constraint checking.
6686 when Attribute_Succ
=> Succ
: declare
6687 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6690 -- For enumeration types with non-standard representations, we
6691 -- expand typ'Pred (x) into:
6693 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6695 -- if the representation is non-contiguous, and just x + 1 if it is
6696 -- after having dealt with constraint checking.
6698 if Is_Enumeration_Type
(Etyp
)
6699 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6701 if Has_Contiguous_Rep
(Etyp
) then
6702 if not Range_Checks_Suppressed
(Ptyp
) then
6703 Set_Do_Range_Check
(First
(Exprs
), False);
6704 Expand_Pred_Succ_Attribute
(N
);
6708 Unchecked_Convert_To
(Etyp
,
6711 Unchecked_Convert_To
(
6713 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
6716 Make_Integer_Literal
(Loc
, 1))));
6719 -- Add Boolean parameter True, to request program error if
6720 -- we have a bad representation on our hands. Add False if
6721 -- checks are suppressed.
6723 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6725 Make_Indexed_Component
(Loc
,
6728 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6729 Expressions
=> New_List
(
6732 Make_Function_Call
(Loc
,
6735 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6736 Parameter_Associations
=> Exprs
),
6737 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6740 -- Suppress checks since they have all been done above
6742 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
6744 -- For floating-point, we transform 'Succ into a call to the Succ
6745 -- floating-point attribute function in Fat_xxx (xxx is root type)
6747 elsif Is_Floating_Point_Type
(Ptyp
) then
6748 Expand_Fpt_Attribute_R
(N
);
6749 Analyze_And_Resolve
(N
, Typ
);
6751 -- For modular types, nothing to do (no overflow, since wraps)
6753 elsif Is_Modular_Integer_Type
(Ptyp
) then
6756 -- For other types, if argument is marked as needing a range check or
6757 -- overflow checking is enabled, we must generate a check.
6759 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6760 or else Do_Range_Check
(First
(Exprs
))
6762 Set_Do_Range_Check
(First
(Exprs
), False);
6763 Expand_Pred_Succ_Attribute
(N
);
6771 -- Transforms X'Tag into a direct reference to the tag of X
6773 when Attribute_Tag
=> Tag
: declare
6775 Prefix_Is_Type
: Boolean;
6778 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6779 Ttyp
:= Entity
(Pref
);
6780 Prefix_Is_Type
:= True;
6783 Prefix_Is_Type
:= False;
6786 -- In the case of a class-wide equivalent type without a parent,
6787 -- the _Tag component has been built in Make_CW_Equivalent_Type
6788 -- manually and must be referenced directly.
6790 if Ekind
(Ttyp
) = E_Class_Wide_Subtype
6791 and then Present
(Equivalent_Type
(Ttyp
))
6792 and then No
(Parent_Subtype
(Equivalent_Type
(Ttyp
)))
6794 Ttyp
:= Equivalent_Type
(Ttyp
);
6796 -- In all the other cases of class-wide type, including an equivalent
6797 -- type with a parent, the _Tag component ultimately present is that
6798 -- of the root type.
6800 elsif Is_Class_Wide_Type
(Ttyp
) then
6801 Ttyp
:= Root_Type
(Ttyp
);
6804 Ttyp
:= Underlying_Type
(Ttyp
);
6806 -- Ada 2005: The type may be a synchronized tagged type, in which
6807 -- case the tag information is stored in the corresponding record.
6809 if Is_Concurrent_Type
(Ttyp
) then
6810 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6813 if Prefix_Is_Type
then
6815 -- For VMs we leave the type attribute unexpanded because
6816 -- there's not a dispatching table to reference.
6818 if Tagged_Type_Expansion
then
6820 Unchecked_Convert_To
(RTE
(RE_Tag
),
6822 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6823 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6826 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6827 -- references the primary tag of the actual object. If 'Tag is
6828 -- applied to class-wide interface objects we generate code that
6829 -- displaces "this" to reference the base of the object.
6831 elsif Comes_From_Source
(N
)
6832 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6833 and then Is_Interface
(Underlying_Type
(Etype
(Prefix
(N
))))
6836 -- (To_Tag_Ptr (Prefix'Address)).all
6838 -- Note that Prefix'Address is recursively expanded into a call
6839 -- to Base_Address (Obj.Tag)
6841 -- Not needed for VM targets, since all handled by the VM
6843 if Tagged_Type_Expansion
then
6845 Make_Explicit_Dereference
(Loc
,
6846 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6847 Make_Attribute_Reference
(Loc
,
6848 Prefix
=> Relocate_Node
(Pref
),
6849 Attribute_Name
=> Name_Address
))));
6850 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6855 Make_Selected_Component
(Loc
,
6856 Prefix
=> Relocate_Node
(Pref
),
6858 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6859 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6867 -- Transforms 'Terminated attribute into a call to Terminated function
6869 when Attribute_Terminated
=> Terminated
: begin
6871 -- The prefix of Terminated is of a task interface class-wide type.
6873 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6875 if Ada_Version
>= Ada_2005
6876 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6877 and then Is_Interface
(Ptyp
)
6878 and then Is_Task_Interface
(Ptyp
)
6881 Make_Function_Call
(Loc
,
6883 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6884 Parameter_Associations
=> New_List
(
6885 Unchecked_Convert_To
6886 (RTE
(RO_ST_Task_Id
),
6887 Build_Disp_Get_Task_Id_Call
(Pref
)))));
6889 elsif Restricted_Profile
then
6891 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6895 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6898 Analyze_And_Resolve
(N
, Standard_Boolean
);
6905 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6906 -- unchecked conversion from (integral) type of X to type address. If
6907 -- the To_Address is a static expression, the transformed expression
6908 -- also needs to be static, because we do some legality checks (e.g.
6909 -- for Thread_Local_Storage) after this transformation.
6912 | Attribute_To_Address
6914 To_Address
: declare
6915 Is_Static
: constant Boolean := Is_Static_Expression
(N
);
6919 Unchecked_Convert_To
(RTE
(RE_Address
),
6920 Relocate_Node
(First
(Exprs
))));
6921 Set_Is_Static_Expression
(N
, Is_Static
);
6923 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6930 when Attribute_To_Any
=> To_Any
: declare
6931 Decls
: constant List_Id
:= New_List
;
6937 Relocate_Node
(First
(Exprs
))), Decls
));
6938 Insert_Actions
(N
, Decls
);
6939 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6946 -- Transforms 'Truncation into a call to the floating-point attribute
6947 -- function Truncation in Fat_xxx (where xxx is the root type).
6948 -- Expansion is avoided for cases the back end can handle directly.
6950 when Attribute_Truncation
=>
6951 if not Is_Inline_Floating_Point_Attribute
(N
) then
6952 Expand_Fpt_Attribute_R
(N
);
6959 when Attribute_TypeCode
=> TypeCode
: declare
6960 Decls
: constant List_Id
:= New_List
;
6962 Rewrite
(N
, Build_TypeCode_Call
(Loc
, Ptyp
, Decls
));
6963 Insert_Actions
(N
, Decls
);
6964 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6967 -----------------------
6968 -- Unbiased_Rounding --
6969 -----------------------
6971 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6972 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6973 -- root type). Expansion is avoided for cases the back end can handle
6976 when Attribute_Unbiased_Rounding
=>
6977 if not Is_Inline_Floating_Point_Attribute
(N
) then
6978 Expand_Fpt_Attribute_R
(N
);
6985 when Attribute_Update
=>
6986 Expand_Update_Attribute
(N
);
6992 -- The processing for VADS_Size is shared with Size
6998 -- For enumeration types with a non-standard representation we use the
6999 -- _Pos_To_Rep array that was created when the type was frozen, unless
7000 -- the representation is contiguous in which case we use an addition.
7002 -- For enumeration types with a standard representation, Val can be
7003 -- rewritten as a simple conversion with Conversion_OK set.
7005 -- For integer types, Val is equivalent to a simple integer conversion
7006 -- and we rewrite it as such.
7008 when Attribute_Val
=> Val
: declare
7009 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
7010 Expr
: constant Node_Id
:= First
(Exprs
);
7014 -- Case of enumeration type
7016 if Is_Enumeration_Type
(Etyp
) then
7018 -- Non-contiguous non-standard enumeration type
7020 if Present
(Enum_Pos_To_Rep
(Etyp
))
7021 and then not Has_Contiguous_Rep
(Etyp
)
7024 Make_Indexed_Component
(Loc
,
7026 New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
7027 Expressions
=> New_List
(
7028 Convert_To
(Standard_Integer
, Expr
))));
7030 Analyze_And_Resolve
(N
, Typ
);
7032 -- Standard or contiguous non-standard enumeration type
7035 -- If the argument is marked as requiring a range check then
7036 -- generate it here, after looking through a conversion to
7037 -- universal integer, if any.
7039 if Do_Range_Check
(Expr
) then
7040 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7041 Rtyp
:= Enum_Pos_To_Rep
(Etyp
);
7046 if Nkind
(Expr
) = N_Type_Conversion
7047 and then Entity
(Subtype_Mark
(Expr
)) = Universal_Integer
7049 Generate_Range_Check
7050 (Expression
(Expr
), Rtyp
, CE_Range_Check_Failed
);
7053 Generate_Range_Check
(Expr
, Rtyp
, CE_Range_Check_Failed
);
7056 Set_Do_Range_Check
(Expr
, False);
7059 -- Contiguous non-standard enumeration type
7061 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7063 Unchecked_Convert_To
(Etyp
,
7066 Make_Integer_Literal
(Loc
,
7067 Enumeration_Rep
(First_Literal
(Etyp
))),
7069 Unchecked_Convert_To
(
7071 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
7074 -- Standard enumeration type
7077 Rewrite
(N
, OK_Convert_To
(Typ
, Expr
));
7080 -- Suppress checks since the range check was done above
7081 -- and it guarantees that the addition cannot overflow.
7083 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
7086 -- Deal with integer types
7088 elsif Is_Integer_Type
(Etyp
) then
7089 Rewrite
(N
, Convert_To
(Typ
, Expr
));
7090 Analyze_And_Resolve
(N
, Typ
);
7098 -- The code for valid is dependent on the particular types involved.
7099 -- See separate sections below for the generated code in each case.
7101 when Attribute_Valid
=> Valid
: declare
7102 PBtyp
: Entity_Id
:= Base_Type
(Ptyp
);
7104 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
7105 -- Save the validity checking mode. We always turn off validity
7106 -- checking during process of 'Valid since this is one place
7107 -- where we do not want the implicit validity checks to interfere
7108 -- with the explicit validity check that the programmer is doing.
7110 function Make_Range_Test
return Node_Id
;
7111 -- Build the code for a range test of the form
7112 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
7114 ---------------------
7115 -- Make_Range_Test --
7116 ---------------------
7118 function Make_Range_Test
return Node_Id
is
7122 -- The prefix of attribute 'Valid should always denote an object
7123 -- reference. The reference is either coming directly from source
7124 -- or is produced by validity check expansion. The object may be
7125 -- wrapped in a conversion in which case the call to Unqual_Conv
7128 -- If the prefix denotes a variable which captures the value of
7129 -- an object for validation purposes, use the variable in the
7130 -- range test. This ensures that no extra copies or extra reads
7131 -- are produced as part of the test. Generate:
7133 -- Temp : ... := Object;
7134 -- if not Temp in ... then
7136 if Is_Validation_Variable_Reference
(Pref
) then
7137 Temp
:= New_Occurrence_Of
(Entity
(Unqual_Conv
(Pref
)), Loc
);
7139 -- Otherwise the prefix is either a source object or a constant
7140 -- produced by validity check expansion. Generate:
7142 -- Temp : constant ... := Pref;
7143 -- if not Temp in ... then
7146 Temp
:= Duplicate_Subexpr
(Pref
);
7151 Left_Opnd
=> Unchecked_Convert_To
(PBtyp
, Temp
),
7155 Unchecked_Convert_To
(PBtyp
,
7156 Make_Attribute_Reference
(Loc
,
7157 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7158 Attribute_Name
=> Name_First
)),
7160 Unchecked_Convert_To
(PBtyp
,
7161 Make_Attribute_Reference
(Loc
,
7162 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7163 Attribute_Name
=> Name_Last
))));
7164 end Make_Range_Test
;
7170 -- Start of processing for Attribute_Valid
7173 -- Do not expand sourced code 'Valid reference in CodePeer mode,
7174 -- will be handled by the back-end directly.
7176 if CodePeer_Mode
and then Comes_From_Source
(N
) then
7180 -- Turn off validity checks. We do not want any implicit validity
7181 -- checks to intefere with the explicit check from the attribute
7183 Validity_Checks_On
:= False;
7185 -- Retrieve the base type. Handle the case where the base type is a
7186 -- private enumeration type.
7188 if Is_Private_Type
(PBtyp
) and then Present
(Full_View
(PBtyp
)) then
7189 PBtyp
:= Full_View
(PBtyp
);
7192 -- Floating-point case. This case is handled by the Valid attribute
7193 -- code in the floating-point attribute run-time library.
7195 if Is_Floating_Point_Type
(Ptyp
) then
7196 Float_Valid
: declare
7200 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
7201 -- Return entity for Pkg.Nam
7203 --------------------
7204 -- Get_Fat_Entity --
7205 --------------------
7207 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
7208 Exp_Name
: constant Node_Id
:=
7209 Make_Selected_Component
(Loc
,
7210 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
7211 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
7213 Find_Selected_Component
(Exp_Name
);
7214 return Entity
(Exp_Name
);
7217 -- Start of processing for Float_Valid
7220 -- The C back end handles Valid for floating-point types
7222 if Modify_Tree_For_C
then
7223 Analyze_And_Resolve
(Pref
, Ptyp
);
7224 Set_Etype
(N
, Standard_Boolean
);
7228 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
7230 -- If the prefix is a reverse SSO component, or is possibly
7231 -- unaligned, first create a temporary copy that is in
7232 -- native SSO, and properly aligned. Make it Volatile to
7233 -- prevent folding in the back-end. Note that we use an
7234 -- intermediate constrained string type to initialize the
7235 -- temporary, as the value at hand might be invalid, and in
7236 -- that case it cannot be copied using a floating point
7239 if In_Reverse_Storage_Order_Object
(Pref
)
7240 or else Is_Possibly_Unaligned_Object
(Pref
)
7243 Temp
: constant Entity_Id
:=
7244 Make_Temporary
(Loc
, 'F');
7246 Fat_S
: constant Entity_Id
:=
7247 Get_Fat_Entity
(Name_S
);
7248 -- Constrained string subtype of appropriate size
7250 Fat_P
: constant Entity_Id
:=
7251 Get_Fat_Entity
(Name_P
);
7254 Decl
: constant Node_Id
:=
7255 Make_Object_Declaration
(Loc
,
7256 Defining_Identifier
=> Temp
,
7257 Aliased_Present
=> True,
7258 Object_Definition
=>
7259 New_Occurrence_Of
(Ptyp
, Loc
));
7262 Set_Aspect_Specifications
(Decl
, New_List
(
7263 Make_Aspect_Specification
(Loc
,
7265 Make_Identifier
(Loc
, Name_Volatile
))));
7271 Make_Assignment_Statement
(Loc
,
7273 Make_Explicit_Dereference
(Loc
,
7275 Unchecked_Convert_To
(Fat_P
,
7276 Make_Attribute_Reference
(Loc
,
7278 New_Occurrence_Of
(Temp
, Loc
),
7280 Name_Unrestricted_Access
))),
7282 Unchecked_Convert_To
(Fat_S
,
7283 Relocate_Node
(Pref
)))),
7285 Suppress
=> All_Checks
);
7287 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
7291 -- We now have an object of the proper endianness and
7292 -- alignment, and can construct a Valid attribute.
7294 -- We make sure the prefix of this valid attribute is
7295 -- marked as not coming from source, to avoid losing
7296 -- warnings from 'Valid looking like a possible update.
7298 Set_Comes_From_Source
(Pref
, False);
7300 Expand_Fpt_Attribute
7301 (N
, Pkg
, Name_Valid
,
7303 Make_Attribute_Reference
(Loc
,
7304 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
7305 Attribute_Name
=> Name_Unrestricted_Access
)));
7308 -- One more task, we still need a range check. Required
7309 -- only if we have a constraint, since the Valid routine
7310 -- catches infinities properly (infinities are never valid).
7312 -- The way we do the range check is simply to create the
7313 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
7315 if not Subtypes_Statically_Match
(Ptyp
, PBtyp
) then
7318 Left_Opnd
=> Relocate_Node
(N
),
7321 Left_Opnd
=> Convert_To
(PBtyp
, Pref
),
7322 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
7326 -- Enumeration type with holes
7328 -- For enumeration types with holes, the Pos value constructed by
7329 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
7330 -- second argument of False returns minus one for an invalid value,
7331 -- and the non-negative pos value for a valid value, so the
7332 -- expansion of X'Valid is simply:
7334 -- type(X)'Pos (X) >= 0
7336 -- We can't quite generate it that way because of the requirement
7337 -- for the non-standard second argument of False in the resulting
7338 -- rep_to_pos call, so we have to explicitly create:
7340 -- _rep_to_pos (X, False) >= 0
7342 -- If we have an enumeration subtype, we also check that the
7343 -- value is in range:
7345 -- _rep_to_pos (X, False) >= 0
7347 -- (X >= type(X)'First and then type(X)'Last <= X)
7349 elsif Is_Enumeration_Type
(Ptyp
)
7350 and then Present
(Enum_Pos_To_Rep
(PBtyp
))
7355 Make_Function_Call
(Loc
,
7357 New_Occurrence_Of
(TSS
(PBtyp
, TSS_Rep_To_Pos
), Loc
),
7358 Parameter_Associations
=> New_List
(
7360 New_Occurrence_Of
(Standard_False
, Loc
))),
7361 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
7363 -- Skip the range test for boolean types, as it buys us
7364 -- nothing. The function called above already fails for
7365 -- values different from both True and False.
7367 if Ptyp
/= PBtyp
and then not Is_Boolean_Type
(PBtyp
)
7369 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(PBtyp
)
7371 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(PBtyp
))
7373 -- The call to Make_Range_Test will create declarations
7374 -- that need a proper insertion point, but Pref is now
7375 -- attached to a node with no ancestor. Attach to tree
7376 -- even if it is to be rewritten below.
7378 Set_Parent
(Tst
, Parent
(N
));
7382 Left_Opnd
=> Make_Range_Test
,
7388 -- Fortran convention booleans
7390 -- For the very special case of Fortran convention booleans, the
7391 -- value is always valid, since it is an integer with the semantics
7392 -- that non-zero is true, and any value is permissible.
7394 elsif Is_Boolean_Type
(Ptyp
)
7395 and then Convention
(Ptyp
) = Convention_Fortran
7397 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
7399 -- For biased representations, we will be doing an unchecked
7400 -- conversion without unbiasing the result. That means that the range
7401 -- test has to take this into account, and the proper form of the
7404 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
7406 elsif Has_Biased_Representation
(Ptyp
) then
7407 PBtyp
:= RTE
(RE_Unsigned_32
);
7411 Unchecked_Convert_To
(PBtyp
, Duplicate_Subexpr
(Pref
)),
7413 Unchecked_Convert_To
(PBtyp
,
7414 Make_Attribute_Reference
(Loc
,
7415 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7416 Attribute_Name
=> Name_Range_Length
))));
7418 -- For all other scalar types, what we want logically is a
7421 -- X in type(X)'First .. type(X)'Last
7423 -- But that's precisely what won't work because of possible
7424 -- unwanted optimization (and indeed the basic motivation for
7425 -- the Valid attribute is exactly that this test does not work).
7426 -- What will work is:
7428 -- PBtyp!(X) >= PBtyp!(type(X)'First)
7430 -- PBtyp!(X) <= PBtyp!(type(X)'Last)
7432 -- where PBtyp is an integer type large enough to cover the full
7433 -- range of possible stored values (i.e. it is chosen on the basis
7434 -- of the size of the type, not the range of the values). We write
7435 -- this as two tests, rather than a range check, so that static
7436 -- evaluation will easily remove either or both of the checks if
7437 -- they can be statically determined to be true (this happens
7438 -- when the type of X is static and the range extends to the full
7439 -- range of stored values).
7441 -- Unsigned types. Note: it is safe to consider only whether the
7442 -- subtype is unsigned, since we will in that case be doing all
7443 -- unsigned comparisons based on the subtype range. Since we use the
7444 -- actual subtype object size, this is appropriate.
7446 -- For example, if we have
7448 -- subtype x is integer range 1 .. 200;
7449 -- for x'Object_Size use 8;
7451 -- Now the base type is signed, but objects of this type are bits
7452 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7453 -- correct, even though a value greater than 127 looks signed to a
7454 -- signed comparison.
7458 Uns
: constant Boolean :=
7459 Is_Unsigned_Type
(Ptyp
)
7460 or else (Is_Private_Type
(Ptyp
)
7461 and then Is_Unsigned_Type
(Btyp
));
7463 P
: Node_Id
:= Pref
;
7466 -- If the prefix is an object, use the Esize from this object
7467 -- to handle in a more user friendly way the case of objects
7468 -- or components with a large Size aspect: if a Size aspect is
7469 -- specified, we want to read a scalar value as large as the
7470 -- Size, unless the Size is larger than
7471 -- System_Max_Integer_Size.
7473 if Nkind
(P
) = N_Selected_Component
then
7474 P
:= Selector_Name
(P
);
7477 if Nkind
(P
) in N_Has_Entity
7478 and then Present
(Entity
(P
))
7479 and then Is_Object
(Entity
(P
))
7480 and then Known_Esize
(Entity
(P
))
7482 if Esize
(Entity
(P
)) <= System_Max_Integer_Size
then
7483 Size
:= Esize
(Entity
(P
));
7485 Size
:= UI_From_Int
(System_Max_Integer_Size
);
7488 Size
:= Esize
(Ptyp
);
7491 PBtyp
:= Small_Integer_Type_For
(Size
, Uns
);
7492 Rewrite
(N
, Make_Range_Test
);
7496 -- If a predicate is present, then we do the predicate test, even if
7497 -- within the predicate function (infinite recursion is warned about
7498 -- in Sem_Attr in that case).
7501 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
7504 if Present
(Pred_Func
) then
7507 Left_Opnd
=> Relocate_Node
(N
),
7508 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
7512 Analyze_And_Resolve
(N
, Standard_Boolean
);
7513 Validity_Checks_On
:= Save_Validity_Checks_On
;
7520 when Attribute_Valid_Value
=>
7521 Exp_Imgv
.Expand_Valid_Value_Attribute
(N
);
7527 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
7528 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7532 -- Assume that the prefix does not need validation
7536 -- Attribute 'Valid_Scalars is not supported on private tagged types;
7537 -- see a detailed explanation where this attribute is analyzed.
7539 if Is_Private_Type
(Ptyp
) and then Is_Tagged_Type
(Ptyp
) then
7542 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7545 elsif not Scalar_Part_Present
(Val_Typ
) then
7548 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7549 -- validated type is a scalar type. Generate:
7551 -- Val_Typ (Pref)'Valid
7553 elsif Is_Scalar_Type
(Val_Typ
) then
7555 Make_Attribute_Reference
(Loc
,
7557 Unchecked_Convert_To
(Val_Typ
, New_Copy_Tree
(Pref
)),
7558 Attribute_Name
=> Name_Valid
);
7560 -- Required by LLVM although the sizes are the same???
7562 if Nkind
(Prefix
(Expr
)) = N_Unchecked_Type_Conversion
then
7563 Set_No_Truncation
(Prefix
(Expr
));
7566 -- Validate the scalar components of an array by iterating over all
7567 -- dimensions of the array while checking individual components.
7569 elsif Is_Array_Type
(Val_Typ
) then
7571 Make_Function_Call
(Loc
,
7574 (Build_Array_VS_Func
7577 Array_Typ
=> Val_Typ
),
7579 Parameter_Associations
=> New_List
(Pref
));
7581 -- Validate the scalar components, discriminants of a record type by
7582 -- examining the structure of a record type.
7584 elsif Is_Record_Type
(Val_Typ
) then
7586 Make_Function_Call
(Loc
,
7589 (Build_Record_VS_Func
7592 Rec_Typ
=> Val_Typ
),
7594 Parameter_Associations
=> New_List
(Pref
));
7597 -- Default the attribute to True when the type of the prefix does not
7601 Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
7605 Analyze_And_Resolve
(N
, Standard_Boolean
);
7606 Set_Is_Static_Expression
(N
, False);
7613 when Attribute_Value
=>
7614 Exp_Imgv
.Expand_Value_Attribute
(N
);
7620 -- The processing for Value_Size shares the processing for Size
7626 -- The processing for Version shares the processing for Body_Version
7632 when Attribute_Wide_Image
=>
7633 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7634 -- back-end knows how to handle this attribute directly.
7636 if CodePeer_Mode
then
7640 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
7642 ---------------------
7643 -- Wide_Wide_Image --
7644 ---------------------
7646 when Attribute_Wide_Wide_Image
=>
7647 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7648 -- back-end knows how to handle this attribute directly.
7650 if CodePeer_Mode
then
7654 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7660 -- We expand typ'Wide_Value (X) into
7663 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7665 -- Wide_String_To_String is a runtime function that converts its wide
7666 -- string argument to String, converting any non-translatable characters
7667 -- into appropriate escape sequences. This preserves the required
7668 -- semantics of Wide_Value in all cases, and results in a very simple
7669 -- implementation approach.
7671 -- Note: for this approach to be fully standard compliant for the cases
7672 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7673 -- method must cover the entire character range (e.g. UTF-8). But that
7674 -- is a reasonable requirement when dealing with encoded character
7675 -- sequences. Presumably if one of the restrictive encoding mechanisms
7676 -- is in use such as Shift-JIS, then characters that cannot be
7677 -- represented using this encoding will not appear in any case.
7679 when Attribute_Wide_Value
=>
7681 Make_Attribute_Reference
(Loc
,
7683 Attribute_Name
=> Name_Value
,
7685 Expressions
=> New_List
(
7686 Make_Function_Call
(Loc
,
7688 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7690 Parameter_Associations
=> New_List
(
7691 Relocate_Node
(First
(Exprs
)),
7692 Make_Integer_Literal
(Loc
,
7693 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7695 Analyze_And_Resolve
(N
, Typ
);
7697 ---------------------
7698 -- Wide_Wide_Value --
7699 ---------------------
7701 -- We expand typ'Wide_Value_Value (X) into
7704 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7706 -- See Wide_Value for more information. This is not quite right where
7707 -- typ = Wide_Wide_Character, because the encoding method may not cover
7708 -- the whole character type.
7710 when Attribute_Wide_Wide_Value
=>
7712 Make_Attribute_Reference
(Loc
,
7714 Attribute_Name
=> Name_Value
,
7716 Expressions
=> New_List
(
7717 Make_Function_Call
(Loc
,
7720 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7722 Parameter_Associations
=> New_List
(
7723 Relocate_Node
(First
(Exprs
)),
7724 Make_Integer_Literal
(Loc
,
7725 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7727 Analyze_And_Resolve
(N
, Typ
);
7729 ---------------------
7730 -- Wide_Wide_Width --
7731 ---------------------
7733 when Attribute_Wide_Wide_Width
=>
7734 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7740 when Attribute_Wide_Width
=>
7741 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7747 when Attribute_Width
=>
7748 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7754 when Attribute_Write
=> Write
: declare
7755 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7756 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7764 -- If no underlying type, we have an error that will be diagnosed
7765 -- elsewhere, so here we just completely ignore the expansion.
7771 -- Stream operations can appear in user code even if the restriction
7772 -- No_Streams is active (for example, when instantiating a predefined
7773 -- container). In that case rewrite the attribute as a Raise to
7774 -- prevent any run-time use.
7776 if Restriction_Active
(No_Streams
) then
7778 Make_Raise_Program_Error
(Sloc
(N
),
7779 Reason
=> PE_Stream_Operation_Not_Allowed
));
7780 Set_Etype
(N
, U_Type
);
7784 -- The simple case, if there is a TSS for Write, just call it
7786 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7788 if Present
(Pname
) then
7792 -- If there is a Stream_Convert pragma, use it, we rewrite
7794 -- sourcetyp'Output (stream, Item)
7798 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7800 -- where strmwrite is the given Write function that converts an
7801 -- argument of type sourcetyp or a type acctyp, from which it is
7802 -- derived to type strmtyp. The conversion to acttyp is required
7803 -- for the derived case.
7805 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7807 if Present
(Prag
) then
7809 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7810 Wfunc
:= Entity
(Expression
(Arg3
));
7813 Make_Attribute_Reference
(Loc
,
7814 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7815 Attribute_Name
=> Name_Output
,
7816 Expressions
=> New_List
(
7817 Relocate_Node
(First
(Exprs
)),
7818 Make_Function_Call
(Loc
,
7819 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7820 Parameter_Associations
=> New_List
(
7821 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7822 Relocate_Node
(Next
(First
(Exprs
)))))))));
7829 elsif Default_Streaming_Unavailable
(U_Type
) then
7830 -- Do the same thing here as is done above in the
7831 -- case where a No_Streams restriction is active.
7834 Make_Raise_Program_Error
(Sloc
(N
),
7835 Reason
=> PE_Stream_Operation_Not_Allowed
));
7836 Set_Etype
(N
, U_Type
);
7839 -- For elementary types, we call the W_xxx routine directly
7841 elsif Is_Elementary_Type
(U_Type
) then
7842 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7848 elsif Is_Array_Type
(U_Type
) then
7849 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7850 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
7852 -- Tagged type case, use the primitive Write function. Note that
7853 -- this will dispatch in the class-wide case which is what we want
7855 elsif Is_Tagged_Type
(U_Type
) then
7856 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7858 -- All other record type cases, including protected records.
7859 -- The latter only arise for expander generated code for
7860 -- handling shared passive partition access.
7864 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7866 -- Ada 2005 (AI-216): Program_Error is raised when executing
7867 -- the default implementation of the Write attribute of an
7868 -- Unchecked_Union type. However, if the 'Write reference is
7869 -- within the generated Output stream procedure, Write outputs
7870 -- the components, and the default values of the discriminant
7871 -- are streamed by the Output procedure itself. If there are
7872 -- no default values this is also erroneous.
7874 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
7875 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7876 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
7877 or else No
(Discriminant_Default_Value
7878 (First_Discriminant
(U_Type
)))
7881 Make_Raise_Program_Error
(Loc
,
7882 Reason
=> PE_Unchecked_Union_Restriction
));
7883 Set_Etype
(N
, U_Type
);
7888 if Has_Defaulted_Discriminants
(U_Type
) then
7889 Build_Mutable_Record_Write_Procedure
7890 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7892 Build_Record_Write_Procedure
7893 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7896 Insert_Action
(N
, Decl
);
7900 -- If we fall through, Pname is the procedure to be called
7902 Rewrite_Attribute_Proc_Call
(Pname
);
7905 -- The following attributes are handled by the back end (except that
7906 -- static cases have already been evaluated during semantic processing,
7907 -- but in any case the back end should not count on this).
7909 when Attribute_Code_Address
7911 | Attribute_Null_Parameter
7912 | Attribute_Passed_By_Reference
7913 | Attribute_Pool_Address
7917 -- The following attributes should not appear at this stage, since they
7918 -- have already been handled by the analyzer (and properly rewritten
7919 -- with corresponding values or entities to represent the right values).
7921 when Attribute_Abort_Signal
7922 | Attribute_Address_Size
7924 | Attribute_Atomic_Always_Lock_Free
7926 | Attribute_Bit_Order
7928 | Attribute_Compiler_Version
7929 | Attribute_Default_Bit_Order
7930 | Attribute_Default_Scalar_Storage_Order
7931 | Attribute_Definite
7938 | Attribute_Fast_Math
7939 | Attribute_First_Valid
7940 | Attribute_Has_Access_Values
7941 | Attribute_Has_Discriminants
7942 | Attribute_Has_Tagged_Values
7944 | Attribute_Last_Valid
7945 | Attribute_Library_Level
7946 | Attribute_Lock_Free
7947 | Attribute_Machine_Emax
7948 | Attribute_Machine_Emin
7949 | Attribute_Machine_Mantissa
7950 | Attribute_Machine_Overflows
7951 | Attribute_Machine_Radix
7952 | Attribute_Machine_Rounds
7953 | Attribute_Max_Alignment_For_Allocation
7954 | Attribute_Max_Integer_Size
7955 | Attribute_Maximum_Alignment
7956 | Attribute_Model_Emin
7957 | Attribute_Model_Epsilon
7958 | Attribute_Model_Mantissa
7959 | Attribute_Model_Small
7961 | Attribute_Partition_ID
7963 | Attribute_Restriction_Set
7964 | Attribute_Safe_Emax
7965 | Attribute_Safe_First
7966 | Attribute_Safe_Large
7967 | Attribute_Safe_Last
7968 | Attribute_Safe_Small
7969 | Attribute_Scalar_Storage_Order
7971 | Attribute_Signed_Zeros
7973 | Attribute_Small_Denominator
7974 | Attribute_Small_Numerator
7975 | Attribute_Storage_Unit
7976 | Attribute_Stub_Type
7977 | Attribute_System_Allocator_Alignment
7978 | Attribute_Target_Name
7979 | Attribute_Type_Class
7980 | Attribute_Type_Key
7981 | Attribute_Unconstrained_Array
7982 | Attribute_Universal_Literal_String
7983 | Attribute_Wchar_T_Size
7984 | Attribute_Word_Size
7986 raise Program_Error
;
7989 -- Note: as mentioned earlier, individual sections of the above case
7990 -- statement assume there is no code after the case statement, and are
7991 -- legitimately allowed to execute return statements if they have nothing
7992 -- more to do, so DO NOT add code at this point.
7995 when RE_Not_Available
=>
7997 end Expand_N_Attribute_Reference
;
7999 --------------------------------
8000 -- Expand_Pred_Succ_Attribute --
8001 --------------------------------
8003 -- For typ'Pred (exp), we generate the check
8005 -- [constraint_error when exp = typ'Base'First]
8007 -- Similarly, for typ'Succ (exp), we generate the check
8009 -- [constraint_error when exp = typ'Base'Last]
8011 -- These checks are not generated for modular types, since the proper
8012 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
8013 -- We also suppress these checks if we are the right side of an assignment
8014 -- statement or the expression of an object declaration, where the flag
8015 -- Suppress_Assignment_Checks is set for the assignment/declaration.
8017 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
8018 Loc
: constant Source_Ptr
:= Sloc
(N
);
8019 P
: constant Node_Id
:= Parent
(N
);
8023 if Attribute_Name
(N
) = Name_Pred
then
8029 if Nkind
(P
) not in N_Assignment_Statement | N_Object_Declaration
8030 or else not Suppress_Assignment_Checks
(P
)
8033 Make_Raise_Constraint_Error
(Loc
,
8037 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
8039 Make_Attribute_Reference
(Loc
,
8041 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
8042 Attribute_Name
=> Cnam
)),
8043 Reason
=> CE_Overflow_Check_Failed
));
8045 end Expand_Pred_Succ_Attribute
;
8047 ---------------------------
8048 -- Expand_Size_Attribute --
8049 ---------------------------
8051 procedure Expand_Size_Attribute
(N
: Node_Id
) is
8052 Loc
: constant Source_Ptr
:= Sloc
(N
);
8053 Typ
: constant Entity_Id
:= Etype
(N
);
8054 Pref
: constant Node_Id
:= Prefix
(N
);
8055 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
8056 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8060 -- Case of known RM_Size of a type
8062 if Id
in Attribute_Size | Attribute_Value_Size
8063 and then Is_Entity_Name
(Pref
)
8064 and then Is_Type
(Entity
(Pref
))
8065 and then Known_Static_RM_Size
(Entity
(Pref
))
8067 Siz
:= RM_Size
(Entity
(Pref
));
8069 -- Case of known Esize of a type
8071 elsif Id
= Attribute_Object_Size
8072 and then Is_Entity_Name
(Pref
)
8073 and then Is_Type
(Entity
(Pref
))
8074 and then Known_Static_Esize
(Entity
(Pref
))
8076 Siz
:= Esize
(Entity
(Pref
));
8078 -- Case of known size of object
8080 elsif Id
= Attribute_Size
8081 and then Is_Entity_Name
(Pref
)
8082 and then Is_Object
(Entity
(Pref
))
8083 and then Known_Static_Esize
(Entity
(Pref
))
8085 Siz
:= Esize
(Entity
(Pref
));
8087 -- For an array component, we can do Size in the front end if the
8088 -- component_size of the array is set.
8090 elsif Nkind
(Pref
) = N_Indexed_Component
then
8091 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
8093 -- For a record component, we can do Size in the front end if there is a
8094 -- component clause, or if the record is packed and the component's size
8095 -- is known at compile time.
8097 elsif Nkind
(Pref
) = N_Selected_Component
then
8099 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
8100 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
8103 if Present
(Component_Clause
(Comp
)) then
8104 Siz
:= Esize
(Comp
);
8106 elsif Is_Packed
(Rec
) then
8107 Siz
:= RM_Size
(Ptyp
);
8110 Apply_Universal_Integer_Attribute_Checks
(N
);
8115 -- All other cases are handled by the back end
8118 -- If Size is applied to a formal parameter that is of a packed
8119 -- array subtype, then apply Size to the actual subtype.
8121 if Is_Entity_Name
(Pref
)
8122 and then Is_Formal
(Entity
(Pref
))
8123 and then Is_Packed_Array
(Ptyp
)
8126 Make_Attribute_Reference
(Loc
,
8128 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
8129 Attribute_Name
=> Name_Size
));
8130 Analyze_And_Resolve
(N
, Typ
);
8132 -- If Size is applied to a dereference of an access to unconstrained
8133 -- packed array, the back end needs to see its unconstrained nominal
8134 -- type, but also a hint to the actual constrained type.
8136 elsif Nkind
(Pref
) = N_Explicit_Dereference
8137 and then Is_Packed_Array
(Ptyp
)
8138 and then not Is_Constrained
(Ptyp
)
8140 Set_Actual_Designated_Subtype
(Pref
, Get_Actual_Subtype
(Pref
));
8142 -- If Size was applied to a slice of a bit-packed array, we rewrite
8143 -- it into the product of Length and Component_Size. We need to do so
8144 -- because bit-packed arrays are represented internally as arrays of
8145 -- System.Unsigned_Types.Packed_Byte for code generation purposes so
8146 -- the size is always rounded up in the back end.
8148 elsif Nkind
(Pref
) = N_Slice
and then Is_Bit_Packed_Array
(Ptyp
) then
8150 Make_Op_Multiply
(Loc
,
8151 Make_Attribute_Reference
(Loc
,
8152 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8153 Attribute_Name
=> Name_Length
),
8154 Make_Attribute_Reference
(Loc
,
8155 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8156 Attribute_Name
=> Name_Component_Size
)));
8157 Analyze_And_Resolve
(N
, Typ
);
8160 -- Apply the required checks last, after rewriting has taken place
8162 Apply_Universal_Integer_Attribute_Checks
(N
);
8166 -- Common processing for record and array component case
8168 if Present
(Siz
) and then Siz
/= 0 then
8170 CS
: constant Boolean := Comes_From_Source
(N
);
8173 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
8175 -- This integer literal is not a static expression. We do not
8176 -- call Analyze_And_Resolve here, because this would activate
8177 -- the circuit for deciding that a static value was out of range,
8178 -- and we don't want that.
8180 -- So just manually set the type, mark the expression as
8181 -- nonstatic, and then ensure that the result is checked
8182 -- properly if the attribute comes from source (if it was
8183 -- internally generated, we never need a constraint check).
8186 Set_Is_Static_Expression
(N
, False);
8189 Apply_Constraint_Check
(N
, Typ
);
8193 end Expand_Size_Attribute
;
8195 -----------------------------
8196 -- Expand_Update_Attribute --
8197 -----------------------------
8199 procedure Expand_Update_Attribute
(N
: Node_Id
) is
8200 procedure Process_Component_Or_Element_Update
8205 -- Generate the statements necessary to update a single component or an
8206 -- element of the prefix. The code is inserted before the attribute N.
8207 -- Temp denotes the entity of the anonymous object created to reflect
8208 -- the changes in values. Comp is the component/index expression to be
8209 -- updated. Expr is an expression yielding the new value of Comp. Typ
8210 -- is the type of the prefix of attribute Update.
8212 procedure Process_Range_Update
8217 -- Generate the statements necessary to update a slice of the prefix.
8218 -- The code is inserted before the attribute N. Temp denotes the entity
8219 -- of the anonymous object created to reflect the changes in values.
8220 -- Comp is range of the slice to be updated. Expr is an expression
8221 -- yielding the new value of Comp. Typ is the type of the prefix of
8222 -- attribute Update.
8224 -----------------------------------------
8225 -- Process_Component_Or_Element_Update --
8226 -----------------------------------------
8228 procedure Process_Component_Or_Element_Update
8234 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8239 -- An array element may be modified by the following relations
8240 -- depending on the number of dimensions:
8242 -- 1 => Expr -- one dimensional update
8243 -- (1, ..., N) => Expr -- multi dimensional update
8245 -- The above forms are converted in assignment statements where the
8246 -- left hand side is an indexed component:
8248 -- Temp (1) := Expr; -- one dimensional update
8249 -- Temp (1, ..., N) := Expr; -- multi dimensional update
8251 if Is_Array_Type
(Typ
) then
8253 -- The index expressions of a multi dimensional array update
8254 -- appear as an aggregate.
8256 if Nkind
(Comp
) = N_Aggregate
then
8257 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
8259 Exprs
:= New_List
(Relocate_Node
(Comp
));
8263 Make_Indexed_Component
(Loc
,
8264 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8265 Expressions
=> Exprs
);
8267 -- A record component update appears in the following form:
8271 -- The above relation is transformed into an assignment statement
8272 -- where the left hand side is a selected component:
8274 -- Temp.Comp := Expr;
8276 else pragma Assert
(Is_Record_Type
(Typ
));
8278 Make_Selected_Component
(Loc
,
8279 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8280 Selector_Name
=> Relocate_Node
(Comp
));
8284 Make_Assignment_Statement
(Loc
,
8286 Expression
=> Relocate_Node
(Expr
)));
8287 end Process_Component_Or_Element_Update
;
8289 --------------------------
8290 -- Process_Range_Update --
8291 --------------------------
8293 procedure Process_Range_Update
8299 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
8300 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8304 -- A range update appears as
8306 -- (Low .. High => Expr)
8308 -- The above construct is transformed into a loop that iterates over
8309 -- the given range and modifies the corresponding array values to the
8312 -- for Index in Low .. High loop
8313 -- Temp (<Index_Typ> (Index)) := Expr;
8316 Index
:= Make_Temporary
(Loc
, 'I');
8319 Make_Loop_Statement
(Loc
,
8321 Make_Iteration_Scheme
(Loc
,
8322 Loop_Parameter_Specification
=>
8323 Make_Loop_Parameter_Specification
(Loc
,
8324 Defining_Identifier
=> Index
,
8325 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
8327 Statements
=> New_List
(
8328 Make_Assignment_Statement
(Loc
,
8330 Make_Indexed_Component
(Loc
,
8331 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8332 Expressions
=> New_List
(
8333 Convert_To
(Index_Typ
,
8334 New_Occurrence_Of
(Index
, Loc
)))),
8335 Expression
=> Relocate_Node
(Expr
))),
8337 End_Label
=> Empty
));
8338 end Process_Range_Update
;
8342 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
8343 Loc
: constant Source_Ptr
:= Sloc
(N
);
8344 Pref
: constant Node_Id
:= Prefix
(N
);
8345 Typ
: constant Entity_Id
:= Etype
(Pref
);
8348 CW_Temp
: Entity_Id
;
8353 -- Start of processing for Expand_Update_Attribute
8356 -- Create the anonymous object to store the value of the prefix and
8357 -- capture subsequent changes in value.
8359 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
8361 -- Preserve the tag of the prefix by offering a specific view of the
8362 -- class-wide version of the prefix.
8364 if Is_Tagged_Type
(Typ
) then
8367 -- CW_Temp : Typ'Class := Typ'Class (Pref);
8369 CW_Temp
:= Make_Temporary
(Loc
, 'T');
8370 CW_Typ
:= Class_Wide_Type
(Typ
);
8373 Make_Object_Declaration
(Loc
,
8374 Defining_Identifier
=> CW_Temp
,
8375 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
8377 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
8380 -- Temp : Typ renames Typ (CW_Temp);
8383 Make_Object_Renaming_Declaration
(Loc
,
8384 Defining_Identifier
=> Temp
,
8385 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
8387 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
8393 -- Temp : Typ := Pref;
8396 Make_Object_Declaration
(Loc
,
8397 Defining_Identifier
=> Temp
,
8398 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8399 Expression
=> Relocate_Node
(Pref
)));
8402 -- Process the update aggregate
8404 Assoc
:= First
(Component_Associations
(Aggr
));
8405 while Present
(Assoc
) loop
8406 Comp
:= First
(Choices
(Assoc
));
8407 Expr
:= Expression
(Assoc
);
8408 while Present
(Comp
) loop
8409 if Nkind
(Comp
) = N_Range
then
8410 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
8411 elsif Nkind
(Comp
) = N_Subtype_Indication
then
8412 Process_Range_Update
8413 (Temp
, Range_Expression
(Constraint
(Comp
)), Expr
, Typ
);
8415 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
8424 -- The attribute is replaced by a reference to the anonymous object
8426 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8428 end Expand_Update_Attribute
;
8434 procedure Find_Fat_Info
8436 Fat_Type
: out Entity_Id
;
8437 Fat_Pkg
: out RE_Id
)
8439 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
8442 -- All we do is use the root type (historically this dealt with
8443 -- VAX-float .. to be cleaned up further later ???)
8445 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8446 Fat_Type
:= Standard_Float
;
8447 Fat_Pkg
:= RE_Attr_Float
;
8449 elsif Rtyp
= Standard_Long_Float
then
8450 Fat_Type
:= Standard_Long_Float
;
8451 Fat_Pkg
:= RE_Attr_Long_Float
;
8453 elsif Rtyp
= Standard_Long_Long_Float
then
8454 Fat_Type
:= Standard_Long_Long_Float
;
8455 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8457 -- Universal real (which is its own root type) is treated as being
8458 -- equivalent to Standard.Long_Long_Float, since it is defined to
8459 -- have the same precision as the longest Float type.
8461 elsif Rtyp
= Universal_Real
then
8462 Fat_Type
:= Standard_Long_Long_Float
;
8463 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8466 raise Program_Error
;
8470 ----------------------------
8471 -- Find_Stream_Subprogram --
8472 ----------------------------
8474 function Find_Stream_Subprogram
8476 Nam
: TSS_Name_Type
) return Entity_Id
8478 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8479 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
8481 if Present
(Ent
) then
8485 -- Stream attributes for strings are expanded into library calls. The
8486 -- following checks are disabled when the run-time is not available or
8487 -- when compiling predefined types due to bootstrap issues. As a result,
8488 -- the compiler will generate in-place stream routines for string types
8489 -- that appear in GNAT's library, but will generate calls via rtsfind
8490 -- to library routines for user code.
8492 -- Note: In the case of using a configurable run time, it is very likely
8493 -- that stream routines for string types are not present (they require
8494 -- file system support). In this case, the specific stream routines for
8495 -- strings are not used, relying on the regular stream mechanism
8496 -- instead. That is why we include the test RTE_Available when dealing
8497 -- with these cases.
8499 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
8500 -- Storage_Array as defined in package System.Storage_Elements
8502 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
8504 -- Case of No_Stream_Optimizations restriction active
8506 if Restriction_Active
(No_Stream_Optimizations
) then
8507 if Nam
= TSS_Stream_Input
8508 and then RTE_Available
(RE_Storage_Array_Input
)
8510 return RTE
(RE_Storage_Array_Input
);
8512 elsif Nam
= TSS_Stream_Output
8513 and then RTE_Available
(RE_Storage_Array_Output
)
8515 return RTE
(RE_Storage_Array_Output
);
8517 elsif Nam
= TSS_Stream_Read
8518 and then RTE_Available
(RE_Storage_Array_Read
)
8520 return RTE
(RE_Storage_Array_Read
);
8522 elsif Nam
= TSS_Stream_Write
8523 and then RTE_Available
(RE_Storage_Array_Write
)
8525 return RTE
(RE_Storage_Array_Write
);
8527 elsif Nam
/= TSS_Stream_Input
and then
8528 Nam
/= TSS_Stream_Output
and then
8529 Nam
/= TSS_Stream_Read
and then
8530 Nam
/= TSS_Stream_Write
8532 raise Program_Error
;
8535 -- Restriction No_Stream_Optimizations is not set, so we can go
8536 -- ahead and optimize using the block IO forms of the routines.
8539 if Nam
= TSS_Stream_Input
8540 and then RTE_Available
(RE_Storage_Array_Input_Blk_IO
)
8542 return RTE
(RE_Storage_Array_Input_Blk_IO
);
8544 elsif Nam
= TSS_Stream_Output
8545 and then RTE_Available
(RE_Storage_Array_Output_Blk_IO
)
8547 return RTE
(RE_Storage_Array_Output_Blk_IO
);
8549 elsif Nam
= TSS_Stream_Read
8550 and then RTE_Available
(RE_Storage_Array_Read_Blk_IO
)
8552 return RTE
(RE_Storage_Array_Read_Blk_IO
);
8554 elsif Nam
= TSS_Stream_Write
8555 and then RTE_Available
(RE_Storage_Array_Write_Blk_IO
)
8557 return RTE
(RE_Storage_Array_Write_Blk_IO
);
8559 elsif Nam
/= TSS_Stream_Input
and then
8560 Nam
/= TSS_Stream_Output
and then
8561 Nam
/= TSS_Stream_Read
and then
8562 Nam
/= TSS_Stream_Write
8564 raise Program_Error
;
8568 -- Stream_Element_Array as defined in package Ada.Streams
8570 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
8572 -- Case of No_Stream_Optimizations restriction active
8574 if Restriction_Active
(No_Stream_Optimizations
) then
8575 if Nam
= TSS_Stream_Input
8576 and then RTE_Available
(RE_Stream_Element_Array_Input
)
8578 return RTE
(RE_Stream_Element_Array_Input
);
8580 elsif Nam
= TSS_Stream_Output
8581 and then RTE_Available
(RE_Stream_Element_Array_Output
)
8583 return RTE
(RE_Stream_Element_Array_Output
);
8585 elsif Nam
= TSS_Stream_Read
8586 and then RTE_Available
(RE_Stream_Element_Array_Read
)
8588 return RTE
(RE_Stream_Element_Array_Read
);
8590 elsif Nam
= TSS_Stream_Write
8591 and then RTE_Available
(RE_Stream_Element_Array_Write
)
8593 return RTE
(RE_Stream_Element_Array_Write
);
8595 elsif Nam
/= TSS_Stream_Input
and then
8596 Nam
/= TSS_Stream_Output
and then
8597 Nam
/= TSS_Stream_Read
and then
8598 Nam
/= TSS_Stream_Write
8600 raise Program_Error
;
8603 -- Restriction No_Stream_Optimizations is not set, so we can go
8604 -- ahead and optimize using the block IO forms of the routines.
8607 if Nam
= TSS_Stream_Input
8608 and then RTE_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
8610 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
8612 elsif Nam
= TSS_Stream_Output
8613 and then RTE_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
8615 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
8617 elsif Nam
= TSS_Stream_Read
8618 and then RTE_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
8620 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
8622 elsif Nam
= TSS_Stream_Write
8623 and then RTE_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
8625 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
8627 elsif Nam
/= TSS_Stream_Input
and then
8628 Nam
/= TSS_Stream_Output
and then
8629 Nam
/= TSS_Stream_Read
and then
8630 Nam
/= TSS_Stream_Write
8632 raise Program_Error
;
8636 -- String as defined in package Ada
8638 elsif Base_Typ
= Standard_String
then
8640 -- Case of No_Stream_Optimizations restriction active
8642 if Restriction_Active
(No_Stream_Optimizations
) then
8643 if Nam
= TSS_Stream_Input
8644 and then RTE_Available
(RE_String_Input
)
8646 return RTE
(RE_String_Input
);
8648 elsif Nam
= TSS_Stream_Output
8649 and then RTE_Available
(RE_String_Output
)
8651 return RTE
(RE_String_Output
);
8653 elsif Nam
= TSS_Stream_Read
8654 and then RTE_Available
(RE_String_Read
)
8656 return RTE
(RE_String_Read
);
8658 elsif Nam
= TSS_Stream_Write
8659 and then RTE_Available
(RE_String_Write
)
8661 return RTE
(RE_String_Write
);
8663 elsif Nam
/= TSS_Stream_Input
and then
8664 Nam
/= TSS_Stream_Output
and then
8665 Nam
/= TSS_Stream_Read
and then
8666 Nam
/= TSS_Stream_Write
8668 raise Program_Error
;
8671 -- Restriction No_Stream_Optimizations is not set, so we can go
8672 -- ahead and optimize using the block IO forms of the routines.
8675 if Nam
= TSS_Stream_Input
8676 and then RTE_Available
(RE_String_Input_Blk_IO
)
8678 return RTE
(RE_String_Input_Blk_IO
);
8680 elsif Nam
= TSS_Stream_Output
8681 and then RTE_Available
(RE_String_Output_Blk_IO
)
8683 return RTE
(RE_String_Output_Blk_IO
);
8685 elsif Nam
= TSS_Stream_Read
8686 and then RTE_Available
(RE_String_Read_Blk_IO
)
8688 return RTE
(RE_String_Read_Blk_IO
);
8690 elsif Nam
= TSS_Stream_Write
8691 and then RTE_Available
(RE_String_Write_Blk_IO
)
8693 return RTE
(RE_String_Write_Blk_IO
);
8695 elsif Nam
/= TSS_Stream_Input
and then
8696 Nam
/= TSS_Stream_Output
and then
8697 Nam
/= TSS_Stream_Read
and then
8698 Nam
/= TSS_Stream_Write
8700 raise Program_Error
;
8704 -- Wide_String as defined in package Ada
8706 elsif Base_Typ
= Standard_Wide_String
then
8708 -- Case of No_Stream_Optimizations restriction active
8710 if Restriction_Active
(No_Stream_Optimizations
) then
8711 if Nam
= TSS_Stream_Input
8712 and then RTE_Available
(RE_Wide_String_Input
)
8714 return RTE
(RE_Wide_String_Input
);
8716 elsif Nam
= TSS_Stream_Output
8717 and then RTE_Available
(RE_Wide_String_Output
)
8719 return RTE
(RE_Wide_String_Output
);
8721 elsif Nam
= TSS_Stream_Read
8722 and then RTE_Available
(RE_Wide_String_Read
)
8724 return RTE
(RE_Wide_String_Read
);
8726 elsif Nam
= TSS_Stream_Write
8727 and then RTE_Available
(RE_Wide_String_Write
)
8729 return RTE
(RE_Wide_String_Write
);
8731 elsif Nam
/= TSS_Stream_Input
and then
8732 Nam
/= TSS_Stream_Output
and then
8733 Nam
/= TSS_Stream_Read
and then
8734 Nam
/= TSS_Stream_Write
8736 raise Program_Error
;
8739 -- Restriction No_Stream_Optimizations is not set, so we can go
8740 -- ahead and optimize using the block IO forms of the routines.
8743 if Nam
= TSS_Stream_Input
8744 and then RTE_Available
(RE_Wide_String_Input_Blk_IO
)
8746 return RTE
(RE_Wide_String_Input_Blk_IO
);
8748 elsif Nam
= TSS_Stream_Output
8749 and then RTE_Available
(RE_Wide_String_Output_Blk_IO
)
8751 return RTE
(RE_Wide_String_Output_Blk_IO
);
8753 elsif Nam
= TSS_Stream_Read
8754 and then RTE_Available
(RE_Wide_String_Read_Blk_IO
)
8756 return RTE
(RE_Wide_String_Read_Blk_IO
);
8758 elsif Nam
= TSS_Stream_Write
8759 and then RTE_Available
(RE_Wide_String_Write_Blk_IO
)
8761 return RTE
(RE_Wide_String_Write_Blk_IO
);
8763 elsif Nam
/= TSS_Stream_Input
and then
8764 Nam
/= TSS_Stream_Output
and then
8765 Nam
/= TSS_Stream_Read
and then
8766 Nam
/= TSS_Stream_Write
8768 raise Program_Error
;
8772 -- Wide_Wide_String as defined in package Ada
8774 elsif Base_Typ
= Standard_Wide_Wide_String
then
8776 -- Case of No_Stream_Optimizations restriction active
8778 if Restriction_Active
(No_Stream_Optimizations
) then
8779 if Nam
= TSS_Stream_Input
8780 and then RTE_Available
(RE_Wide_Wide_String_Input
)
8782 return RTE
(RE_Wide_Wide_String_Input
);
8784 elsif Nam
= TSS_Stream_Output
8785 and then RTE_Available
(RE_Wide_Wide_String_Output
)
8787 return RTE
(RE_Wide_Wide_String_Output
);
8789 elsif Nam
= TSS_Stream_Read
8790 and then RTE_Available
(RE_Wide_Wide_String_Read
)
8792 return RTE
(RE_Wide_Wide_String_Read
);
8794 elsif Nam
= TSS_Stream_Write
8795 and then RTE_Available
(RE_Wide_Wide_String_Write
)
8797 return RTE
(RE_Wide_Wide_String_Write
);
8799 elsif Nam
/= TSS_Stream_Input
and then
8800 Nam
/= TSS_Stream_Output
and then
8801 Nam
/= TSS_Stream_Read
and then
8802 Nam
/= TSS_Stream_Write
8804 raise Program_Error
;
8807 -- Restriction No_Stream_Optimizations is not set, so we can go
8808 -- ahead and optimize using the block IO forms of the routines.
8811 if Nam
= TSS_Stream_Input
8812 and then RTE_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8814 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8816 elsif Nam
= TSS_Stream_Output
8817 and then RTE_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8819 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8821 elsif Nam
= TSS_Stream_Read
8822 and then RTE_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8824 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8826 elsif Nam
= TSS_Stream_Write
8827 and then RTE_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8829 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8831 elsif Nam
/= TSS_Stream_Input
and then
8832 Nam
/= TSS_Stream_Output
and then
8833 Nam
/= TSS_Stream_Read
and then
8834 Nam
/= TSS_Stream_Write
8836 raise Program_Error
;
8842 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8843 return Find_Prim_Op
(Typ
, Nam
);
8845 return Find_Inherited_TSS
(Typ
, Nam
);
8847 end Find_Stream_Subprogram
;
8853 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8857 BT
:= Base_Type
(T
);
8859 if Is_Private_Type
(BT
)
8860 and then Present
(Full_View
(BT
))
8862 BT
:= Full_View
(BT
);
8868 -------------------------------
8869 -- Get_Stream_Convert_Pragma --
8870 -------------------------------
8872 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8877 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8878 -- that a stream convert pragma for a tagged type is not inherited from
8879 -- its parent. Probably what is wrong here is that it is basically
8880 -- incorrect to consider a stream convert pragma to be a representation
8881 -- pragma at all ???
8883 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8884 while Present
(N
) loop
8885 if Nkind
(N
) = N_Pragma
8886 and then Pragma_Name
(N
) = Name_Stream_Convert
8888 -- For tagged types this pragma is not inherited, so we
8889 -- must verify that it is defined for the given type and
8893 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8895 if not Is_Tagged_Type
(T
)
8897 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8907 end Get_Stream_Convert_Pragma
;
8909 ---------------------------------
8910 -- Is_Constrained_Packed_Array --
8911 ---------------------------------
8913 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8914 Arr
: Entity_Id
:= Typ
;
8917 if Is_Access_Type
(Arr
) then
8918 Arr
:= Designated_Type
(Arr
);
8921 return Is_Array_Type
(Arr
)
8922 and then Is_Constrained
(Arr
)
8923 and then Present
(Packed_Array_Impl_Type
(Arr
));
8924 end Is_Constrained_Packed_Array
;
8926 ----------------------------------------
8927 -- Is_Inline_Floating_Point_Attribute --
8928 ----------------------------------------
8930 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8931 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8933 function Is_GCC_Target
return Boolean;
8934 -- Return True if we are using a GCC target/back-end
8935 -- ??? Note: the implementation is kludgy/fragile
8941 function Is_GCC_Target
return Boolean is
8943 return not CodePeer_Mode
8944 and then not Modify_Tree_For_C
;
8947 -- Start of processing for Is_Inline_Floating_Point_Attribute
8950 -- Machine and Model can be expanded by the GCC back end only
8952 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8953 return Is_GCC_Target
;
8955 -- Remaining cases handled by all back ends are Rounding and Truncation
8956 -- when appearing as the operand of a conversion to some integer type.
8958 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8959 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8964 -- Here we are in the integer conversion context. We reuse Rounding for
8965 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
8968 Id
= Attribute_Rounding
8969 or else Id
= Attribute_Machine_Rounding
8970 or else Id
= Attribute_Truncation
;
8971 end Is_Inline_Floating_Point_Attribute
;