1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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 Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Elists
; use Elists
;
35 with Exp_Atag
; use Exp_Atag
;
36 with Exp_Ch3
; use Exp_Ch3
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Imgv
; use Exp_Imgv
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Strm
; use Exp_Strm
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Expander
; use Expander
;
47 with Freeze
; use Freeze
;
48 with Gnatvsn
; use Gnatvsn
;
49 with Itypes
; use Itypes
;
51 with Namet
; use Namet
;
52 with Nmake
; use Nmake
;
53 with Nlists
; use Nlists
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch6
; use Sem_Ch6
;
61 with Sem_Ch7
; use Sem_Ch7
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Util
; use Sem_Util
;
66 with Sinfo
; use Sinfo
;
67 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
68 with Sinfo
.Utils
; use Sinfo
.Utils
;
69 with Snames
; use Snames
;
70 with Stand
; use Stand
;
71 with Stringt
; use Stringt
;
72 with Strub
; use Strub
;
73 with Tbuild
; use Tbuild
;
74 with Ttypes
; use Ttypes
;
75 with Uintp
; use Uintp
;
76 with Uname
; use Uname
;
77 with Urealp
; use Urealp
;
78 with Validsw
; use Validsw
;
80 package body Exp_Attr
is
82 -----------------------
83 -- Local Subprograms --
84 -----------------------
86 function Build_Array_VS_Func
88 Formal_Typ
: Entity_Id
;
89 Array_Typ
: Entity_Id
) return Entity_Id
;
90 -- Validate the components of an array type by means of a function. Return
91 -- the entity of the validation function. The parameters are as follows:
93 -- * Attr - the 'Valid_Scalars attribute for which the function is
96 -- * Formal_Typ - the type of the generated function's only formal
99 -- * Array_Typ - the array type whose components are to be validated
101 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
102 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
104 function Build_Record_VS_Func
106 Formal_Typ
: Entity_Id
;
107 Rec_Typ
: Entity_Id
) return Entity_Id
;
108 -- Validate the components, discriminants, and variants of a record type by
109 -- means of a function. Return the entity of the validation function. The
110 -- parameters are as follows:
112 -- * Attr - the 'Valid_Scalars attribute for which the function is
115 -- * Formal_Typ - the type of the generated function's only formal
118 -- * Rec_Typ - the record type whose internals are to be validated
120 procedure Compile_Stream_Body_In_Scope
124 -- The body for a stream subprogram may be generated outside of the scope
125 -- of the type. If the type is fully private, it may depend on the full
126 -- view of other types (e.g. indexes) that are currently private as well.
127 -- We install the declarations of the package in which the type is declared
128 -- before compiling the body in what is its proper environment. The Check
129 -- parameter indicates if checks are to be suppressed for the stream body.
130 -- We suppress checks for array/record reads, since the rule is that these
131 -- are like assignments, out of range values due to uninitialized storage,
132 -- or other invalid values do NOT cause a Constraint_Error to be raised.
133 -- If we are within an instance body all visibility has been established
134 -- already and there is no need to install the package.
136 -- This mechanism is now extended to the component types of the array type,
137 -- when the component type is not in scope and is private, to handle
138 -- properly the case when the full view has defaulted discriminants.
140 -- This special processing is ultimately caused by the fact that the
141 -- compiler lacks a well-defined phase when full views are visible
142 -- everywhere. Having such a separate pass would remove much of the
143 -- special-case code that shuffles partial and full views in the middle
144 -- of semantic analysis and expansion.
146 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean;
148 -- In most cases, references to unavailable streaming attributes
149 -- are rejected at compile time. In some obscure cases involving
150 -- generics and formal derived types, the problem is dealt with at runtime.
152 procedure Expand_Access_To_Protected_Op
156 -- An attribute reference to a protected subprogram is transformed into
157 -- a pair of pointers: one to the object, and one to the operations.
158 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
160 procedure Expand_Fpt_Attribute
165 -- This procedure expands a call to a floating-point attribute function.
166 -- N is the attribute reference node, and Args is a list of arguments to
167 -- be passed to the function call. Pkg identifies the package containing
168 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
169 -- have already been converted to the floating-point type for which Pkg was
170 -- instantiated. The Nam argument is the relevant attribute processing
171 -- routine to be called. This is the same as the attribute name.
173 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
174 -- This procedure expands a call to a floating-point attribute function
175 -- that takes a single floating-point argument. The function to be called
176 -- is always the same as the attribute name.
178 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
179 -- This procedure expands a call to a floating-point attribute function
180 -- that takes one floating-point argument and one integer argument. The
181 -- function to be called is always the same as the attribute name.
183 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
184 -- This procedure expands a call to a floating-point attribute function
185 -- that takes two floating-point arguments. The function to be called
186 -- is always the same as the attribute name.
188 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
189 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
190 -- loop may be converted into a conditional block. See body for details.
192 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
193 -- Handle the expansion of attributes 'Max and 'Min, including expanding
194 -- then out if we are in Modify_Tree_For_C mode.
196 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
197 -- Handles expansion of Pred or Succ attributes for case of non-real
198 -- operand with overflow checking required.
200 procedure Expand_Update_Attribute
(N
: Node_Id
);
201 -- Handle the expansion of attribute Update
203 procedure Find_Fat_Info
205 Fat_Type
: out Entity_Id
;
206 Fat_Pkg
: out RE_Id
);
207 -- Given a floating-point type T, identifies the package containing the
208 -- attributes for this type (returned in Fat_Pkg), and the corresponding
209 -- type for which this package was instantiated from Fat_Gen. Error if T
210 -- is not a floating-point type.
212 function Find_Stream_Subprogram
214 Nam
: TSS_Name_Type
) return Entity_Id
;
215 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
216 -- types, the corresponding primitive operation is looked up, else the
217 -- appropriate TSS from the type itself, or from its closest ancestor
218 -- defining it, is returned. In both cases, inheritance of representation
219 -- aspects is thus taken into account.
221 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
222 -- The stream functions need to examine the underlying representation of
223 -- composite types. In some cases T may be non-private but its base type
224 -- is, in which case the function returns the corresponding full view.
226 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
227 -- Given a type, find a corresponding stream convert pragma that applies to
228 -- the implementation base type of this type (Typ). If found, return the
229 -- pragma node, otherwise return Empty if no pragma is found.
231 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
232 -- Utility for array attributes, returns true on packed constrained
233 -- arrays, and on access to same.
235 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
236 -- Returns true iff the given node refers to an attribute call that
237 -- can be expanded directly by the back end and does not need front end
238 -- expansion. Typically used for rounding and truncation attributes that
239 -- appear directly inside a conversion to integer.
241 -------------------------
242 -- Build_Array_VS_Func --
243 -------------------------
245 function Build_Array_VS_Func
247 Formal_Typ
: Entity_Id
;
248 Array_Typ
: Entity_Id
) return Entity_Id
250 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
251 Comp_Typ
: constant Entity_Id
:=
252 Validated_View
(Component_Type
(Array_Typ
));
254 function Validate_Component
256 Indexes
: List_Id
) return Node_Id
;
257 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
258 -- the entity of the validation parameter. Return the check associated
259 -- with the component.
261 function Validate_Dimension
264 Indexes
: List_Id
) return Node_Id
;
265 -- Process dimension Dim of the array type. Obj_Id denotes the entity
266 -- of the validation parameter. Indexes is a list where each dimension
267 -- deposits its loop variable, which will later identify a component.
268 -- Return the loop associated with the current dimension.
270 ------------------------
271 -- Validate_Component --
272 ------------------------
274 function Validate_Component
276 Indexes
: List_Id
) return Node_Id
281 if Is_Scalar_Type
(Comp_Typ
) then
282 Attr_Nam
:= Name_Valid
;
284 Attr_Nam
:= Name_Valid_Scalars
;
288 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
293 Make_If_Statement
(Loc
,
297 Make_Attribute_Reference
(Loc
,
299 Make_Indexed_Component
(Loc
,
301 Unchecked_Convert_To
(Array_Typ
,
302 New_Occurrence_Of
(Obj_Id
, Loc
)),
303 Expressions
=> Indexes
),
304 Attribute_Name
=> Attr_Nam
)),
306 Then_Statements
=> New_List
(
307 Make_Simple_Return_Statement
(Loc
,
308 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
309 end Validate_Component
;
311 ------------------------
312 -- Validate_Dimension --
313 ------------------------
315 function Validate_Dimension
318 Indexes
: List_Id
) return Node_Id
323 -- Validate the component once all dimensions have produced their
326 if Dim
> Number_Dimensions
(Array_Typ
) then
327 return Validate_Component
(Obj_Id
, Indexes
);
329 -- Process the current dimension
333 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
));
335 Append_To
(Indexes
, New_Occurrence_Of
(Index
, Loc
));
338 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
339 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
340 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
348 Make_Implicit_Loop_Statement
(Attr
,
351 Make_Iteration_Scheme
(Loc
,
352 Loop_Parameter_Specification
=>
353 Make_Loop_Parameter_Specification
(Loc
,
354 Defining_Identifier
=> Index
,
355 Discrete_Subtype_Definition
=>
356 Make_Attribute_Reference
(Loc
,
358 Unchecked_Convert_To
(Array_Typ
,
359 New_Occurrence_Of
(Obj_Id
, Loc
)),
360 Attribute_Name
=> Name_Range
,
361 Expressions
=> New_List
(
362 Make_Integer_Literal
(Loc
, Dim
))))),
363 Statements
=> New_List
(
364 Validate_Dimension
(Obj_Id
, Dim
+ 1, Indexes
)));
366 end Validate_Dimension
;
370 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
371 Indexes
: constant List_Id
:= New_List
;
372 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
375 -- Start of processing for Build_Array_VS_Func
378 Stmts
:= New_List
(Validate_Dimension
(Obj_Id
, 1, Indexes
));
384 Make_Simple_Return_Statement
(Loc
,
385 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
388 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
393 Mutate_Ekind
(Func_Id
, E_Function
);
394 Set_Is_Internal
(Func_Id
);
395 Set_Is_Pure
(Func_Id
);
397 if not Debug_Generated_Code
then
398 Set_Debug_Info_Off
(Func_Id
);
402 Make_Subprogram_Body
(Loc
,
404 Make_Function_Specification
(Loc
,
405 Defining_Unit_Name
=> Func_Id
,
406 Parameter_Specifications
=> New_List
(
407 Make_Parameter_Specification
(Loc
,
408 Defining_Identifier
=> Obj_Id
,
409 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
411 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
412 Declarations
=> New_List
,
413 Handled_Statement_Sequence
=>
414 Make_Handled_Sequence_Of_Statements
(Loc
,
415 Statements
=> Stmts
)));
418 end Build_Array_VS_Func
;
420 ---------------------------------
421 -- Build_Disp_Get_Task_Id_Call --
422 ---------------------------------
424 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
425 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
426 Typ
: constant Entity_Id
:= Etype
(Actual
);
427 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
431 -- _Disp_Get_Task_Id (Actual)
434 Make_Function_Call
(Loc
,
435 Name
=> New_Occurrence_Of
(Subp
, Loc
),
436 Parameter_Associations
=> New_List
(Actual
));
437 end Build_Disp_Get_Task_Id_Call
;
439 --------------------------
440 -- Build_Record_VS_Func --
441 --------------------------
443 function Build_Record_VS_Func
445 Formal_Typ
: Entity_Id
;
446 Rec_Typ
: Entity_Id
) return Entity_Id
448 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
449 -- It generates code only when there are components, discriminants,
450 -- or variant parts to validate.
452 -- NOTE: The routines within Build_Record_VS_Func are intentionally
453 -- unnested to avoid deep indentation of code.
455 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
457 procedure Validate_Component_List
460 Stmts
: in out List_Id
);
461 -- Process all components and variant parts of component list Comp_List.
462 -- Obj_Id denotes the entity of the validation parameter. All new code
463 -- is added to list Stmts.
465 procedure Validate_Field
468 Cond
: in out Node_Id
);
469 -- Process component declaration or discriminant specification Field.
470 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
471 -- an "or else" conditional expression which contains the new code (if
474 procedure Validate_Fields
477 Stmts
: in out List_Id
);
478 -- Process component declarations or discriminant specifications in list
479 -- Fields. Obj_Id denotes the entity of the validation parameter. All
480 -- new code is added to list Stmts.
482 procedure Validate_Variant
485 Alts
: in out List_Id
);
486 -- Process variant Var. Obj_Id denotes the entity of the validation
487 -- parameter. Alts denotes a list of case statement alternatives which
488 -- contains the new code (if any).
490 procedure Validate_Variant_Part
493 Stmts
: in out List_Id
);
494 -- Process variant part Var_Part. Obj_Id denotes the entity of the
495 -- validation parameter. All new code is added to list Stmts.
497 -----------------------------
498 -- Validate_Component_List --
499 -----------------------------
501 procedure Validate_Component_List
504 Stmts
: in out List_Id
)
506 Var_Part
: constant Node_Id
:= Variant_Part
(Comp_List
);
509 -- Validate all components
513 Fields
=> Component_Items
(Comp_List
),
516 -- Validate the variant part
518 if Present
(Var_Part
) then
519 Validate_Variant_Part
521 Var_Part
=> Var_Part
,
524 end Validate_Component_List
;
530 procedure Validate_Field
533 Cond
: in out Node_Id
)
535 Field_Id
: constant Entity_Id
:= Defining_Entity
(Field
);
536 Field_Nam
: constant Name_Id
:= Chars
(Field_Id
);
537 Field_Typ
: constant Entity_Id
:= Validated_View
(Etype
(Field_Id
));
541 -- Do not process internally-generated fields. Note that checking for
542 -- Comes_From_Source is not correct because this will eliminate the
543 -- components within the corresponding record of a protected type.
545 if Field_Nam
in Name_uObject | Name_uParent | Name_uTag
then
548 -- Do not process fields without any scalar components
550 elsif not Scalar_Part_Present
(Field_Typ
) then
553 -- Otherwise the field needs to be validated. Use Make_Identifier
554 -- rather than New_Occurrence_Of to identify the field because the
555 -- wrong entity may be picked up when private types are involved.
558 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
561 if Is_Scalar_Type
(Field_Typ
) then
562 Attr_Nam
:= Name_Valid
;
564 Attr_Nam
:= Name_Valid_Scalars
;
567 Evolve_Or_Else
(Cond
,
570 Make_Attribute_Reference
(Loc
,
572 Make_Selected_Component
(Loc
,
574 Unchecked_Convert_To
(Rec_Typ
,
575 New_Occurrence_Of
(Obj_Id
, Loc
)),
576 Selector_Name
=> Make_Identifier
(Loc
, Field_Nam
)),
577 Attribute_Name
=> Attr_Nam
)));
581 ---------------------
582 -- Validate_Fields --
583 ---------------------
585 procedure Validate_Fields
588 Stmts
: in out List_Id
)
594 -- Assume that none of the fields are eligible for verification
598 -- Validate all fields
600 Field
:= First_Non_Pragma
(Fields
);
601 while Present
(Field
) loop
607 Next_Non_Pragma
(Field
);
611 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
612 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
617 if Present
(Cond
) then
618 Append_New_To
(Stmts
,
619 Make_Implicit_If_Statement
(Attr
,
621 Then_Statements
=> New_List
(
622 Make_Simple_Return_Statement
(Loc
,
623 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
627 ----------------------
628 -- Validate_Variant --
629 ----------------------
631 procedure Validate_Variant
634 Alts
: in out List_Id
)
639 -- Assume that none of the components and variants are eligible for
644 -- Validate components
646 Validate_Component_List
648 Comp_List
=> Component_List
(Var
),
651 -- Generate a null statement in case none of the components were
652 -- verified because this will otherwise eliminate an alternative
653 -- from the variant case statement and render the generated code
657 Append_New_To
(Stmts
, Make_Null_Statement
(Loc
));
661 -- when Discrete_Choices =>
665 Make_Case_Statement_Alternative
(Loc
,
667 New_Copy_List_Tree
(Discrete_Choices
(Var
)),
668 Statements
=> Stmts
));
669 end Validate_Variant
;
671 ---------------------------
672 -- Validate_Variant_Part --
673 ---------------------------
675 procedure Validate_Variant_Part
678 Stmts
: in out List_Id
)
680 Vars
: constant List_Id
:= Variants
(Var_Part
);
685 -- Assume that none of the variants are eligible for verification
691 Var
:= First_Non_Pragma
(Vars
);
692 while Present
(Var
) loop
698 Next_Non_Pragma
(Var
);
701 -- Even though individual variants may lack eligible components, the
702 -- alternatives must still be generated.
704 pragma Assert
(Present
(Alts
));
707 -- case Rec_Typ (Obj_Id).Discriminant is
708 -- when Discrete_Choices_1 =>
710 -- when Discrete_Choices_N =>
714 Append_New_To
(Stmts
,
715 Make_Case_Statement
(Loc
,
717 Make_Selected_Component
(Loc
,
719 Unchecked_Convert_To
(Rec_Typ
,
720 New_Occurrence_Of
(Obj_Id
, Loc
)),
721 Selector_Name
=> New_Copy_Tree
(Name
(Var_Part
))),
722 Alternatives
=> Alts
));
723 end Validate_Variant_Part
;
727 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
728 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
736 -- Start of processing for Build_Record_VS_Func
739 Typ
:= Validated_View
(Rec_Typ
);
741 -- Use the root type when dealing with a class-wide type
743 if Is_Class_Wide_Type
(Typ
) then
744 Typ
:= Validated_View
(Root_Type
(Typ
));
747 Typ_Decl
:= Declaration_Node
(Typ
);
748 Typ_Def
:= Type_Definition
(Typ_Decl
);
750 -- The components of a derived type are located in the extension part
752 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
753 Typ_Ext
:= Record_Extension_Part
(Typ_Def
);
755 if Present
(Typ_Ext
) then
756 Comps
:= Component_List
(Typ_Ext
);
761 -- Otherwise the components are available in the definition
764 Comps
:= Component_List
(Typ_Def
);
767 -- The code generated by this routine is as follows:
769 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
771 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
772 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
777 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
778 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
783 -- case Discriminant_1 is
785 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
786 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
791 -- case Discriminant_N is
800 -- Assume that the record type lacks eligible components, discriminants,
801 -- and variant parts.
805 -- Validate the discriminants
807 if not Is_Unchecked_Union
(Rec_Typ
) then
810 Fields
=> Discriminant_Specifications
(Typ_Decl
),
814 -- Validate the components and variant parts
816 Validate_Component_List
824 Append_New_To
(Stmts
,
825 Make_Simple_Return_Statement
(Loc
,
826 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
829 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
834 Mutate_Ekind
(Func_Id
, E_Function
);
835 Set_Is_Internal
(Func_Id
);
836 Set_Is_Pure
(Func_Id
);
838 if not Debug_Generated_Code
then
839 Set_Debug_Info_Off
(Func_Id
);
843 Make_Subprogram_Body
(Loc
,
845 Make_Function_Specification
(Loc
,
846 Defining_Unit_Name
=> Func_Id
,
847 Parameter_Specifications
=> New_List
(
848 Make_Parameter_Specification
(Loc
,
849 Defining_Identifier
=> Obj_Id
,
850 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
852 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
853 Declarations
=> New_List
,
854 Handled_Statement_Sequence
=>
855 Make_Handled_Sequence_Of_Statements
(Loc
,
856 Statements
=> Stmts
)),
857 Suppress
=> Discriminant_Check
);
860 end Build_Record_VS_Func
;
862 ----------------------------------
863 -- Compile_Stream_Body_In_Scope --
864 ----------------------------------
866 procedure Compile_Stream_Body_In_Scope
871 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
872 Curr
: constant Entity_Id
:= Current_Scope
;
873 Install
: Boolean := False;
874 Scop
: Entity_Id
:= Scope
(Arr
);
878 and then not In_Open_Scopes
(Scop
)
879 and then Ekind
(Scop
) = E_Package
884 -- The component type may be private, in which case we install its
885 -- full view to compile the subprogram.
887 -- The component type may be private, in which case we install its
888 -- full view to compile the subprogram. We do not do this if the
889 -- type has a Stream_Convert pragma, which indicates that there are
890 -- special stream-processing operations for that type (for example
891 -- Unbounded_String and its wide varieties).
893 -- We don't install the package either if array type and element
894 -- type come from the same package, and the original array type is
895 -- private, because in this case the underlying type Arr is
896 -- itself a full view, which carries the full view of the component.
898 Scop
:= Scope
(C_Type
);
900 if Is_Private_Type
(C_Type
)
901 and then Present
(Full_View
(C_Type
))
902 and then not In_Open_Scopes
(Scop
)
903 and then Ekind
(Scop
) = E_Package
904 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
906 if Scope
(Arr
) = Scope
(C_Type
)
907 and then Is_Private_Type
(Etype
(Prefix
(N
)))
908 and then Full_View
(Etype
(Prefix
(N
))) = Arr
918 -- If we are within an instance body, then all visibility has been
919 -- established already and there is no need to install the package.
921 if Install
and then not In_Instance_Body
then
923 Install_Visible_Declarations
(Scop
);
924 Install_Private_Declarations
(Scop
);
926 -- The entities in the package are now visible, but the generated
927 -- stream entity must appear in the current scope (usually an
928 -- enclosing stream function) so that itypes all have their proper
936 Insert_Action
(N
, Decl
);
940 -- Remove extra copy of current scope, and package itself
943 End_Package_Scope
(Scop
);
945 end Compile_Stream_Body_In_Scope
;
947 -----------------------------------
948 -- Default_Streaming_Unavailable --
949 -----------------------------------
951 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean is
952 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
954 if Is_Immutably_Limited_Type
(Btyp
)
955 and then not Is_Tagged_Type
(Btyp
)
956 and then not (Ekind
(Btyp
) = E_Record_Type
957 and then Present
(Corresponding_Concurrent_Type
(Btyp
)))
959 pragma Assert
(In_Instance_Body
);
963 end Default_Streaming_Unavailable
;
965 -----------------------------------
966 -- Expand_Access_To_Protected_Op --
967 -----------------------------------
969 procedure Expand_Access_To_Protected_Op
974 -- The value of the attribute_reference is a record containing two
975 -- fields: an access to the protected object, and an access to the
976 -- subprogram itself. The prefix is an identifier or a selected
979 function Has_By_Protected_Procedure_Prefixed_View
return Boolean;
980 -- Determine whether Pref denotes the prefixed class-wide interface
981 -- view of a procedure with synchronization kind By_Protected_Procedure.
983 ----------------------------------------------
984 -- Has_By_Protected_Procedure_Prefixed_View --
985 ----------------------------------------------
987 function Has_By_Protected_Procedure_Prefixed_View
return Boolean is
989 return Nkind
(Pref
) = N_Selected_Component
990 and then Nkind
(Prefix
(Pref
)) in N_Has_Entity
991 and then Present
(Entity
(Prefix
(Pref
)))
992 and then Is_Class_Wide_Type
(Etype
(Entity
(Prefix
(Pref
))))
993 and then (Is_Synchronized_Interface
(Etype
(Entity
(Prefix
(Pref
))))
995 Is_Protected_Interface
(Etype
(Entity
(Prefix
(Pref
)))))
996 and then Is_By_Protected_Procedure
(Entity
(Selector_Name
(Pref
)));
997 end Has_By_Protected_Procedure_Prefixed_View
;
1001 Loc
: constant Source_Ptr
:= Sloc
(N
);
1003 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1004 Sub
: Entity_Id
:= Empty
;
1006 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
1007 Acc
: constant Entity_Id
:=
1008 Etype
(Next_Component
(First_Component
(E_T
)));
1012 -- Start of processing for Expand_Access_To_Protected_Op
1015 -- Within the body of the protected type, the prefix designates a local
1016 -- operation, and the object is the first parameter of the corresponding
1017 -- protected body of the current enclosing operation.
1019 if Is_Entity_Name
(Pref
) then
1020 -- All indirect calls are external calls, so must do locking and
1021 -- barrier reevaluation, even if the 'Access occurs within the
1022 -- protected body. Hence the call to External_Subprogram, as opposed
1023 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
1024 -- that indirect calls from within the same protected body will
1025 -- deadlock, as allowed by RM-9.5.1(8,15,17).
1027 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
1029 -- Don't traverse the scopes when the attribute occurs within an init
1030 -- proc, because we directly use the _init formal of the init proc in
1033 Curr
:= Current_Scope
;
1034 if not Is_Init_Proc
(Curr
) then
1035 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
1037 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
1038 Curr
:= Scope
(Curr
);
1042 -- In case of protected entries the first formal of its Protected_
1043 -- Body_Subprogram is the address of the object.
1045 if Ekind
(Curr
) = E_Entry
then
1049 (Protected_Body_Subprogram
(Curr
)), Loc
);
1051 -- If the current scope is an init proc, then use the address of the
1052 -- _init formal as the object reference.
1054 elsif Is_Init_Proc
(Curr
) then
1056 Make_Attribute_Reference
(Loc
,
1057 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
1058 Attribute_Name
=> Name_Address
);
1060 -- In case of protected subprograms the first formal of its
1061 -- Protected_Body_Subprogram is the object and we get its address.
1065 Make_Attribute_Reference
(Loc
,
1069 (Protected_Body_Subprogram
(Curr
)), Loc
),
1070 Attribute_Name
=> Name_Address
);
1073 elsif Has_By_Protected_Procedure_Prefixed_View
then
1075 Make_Attribute_Reference
(Loc
,
1076 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1077 Attribute_Name
=> Name_Address
);
1079 -- Analyze the object address with expansion disabled. Required
1080 -- because its expansion would displace the pointer to the object,
1081 -- which is not correct at this stage since the object type is a
1082 -- class-wide interface type and we are dispatching a call to a
1083 -- thunk (which would erroneously displace the pointer again).
1085 Expander_Mode_Save_And_Set
(False);
1087 Set_Analyzed
(Obj_Ref
);
1088 Expander_Mode_Restore
;
1090 -- Case where the prefix is not an entity name. Find the
1091 -- version of the protected operation to be called from
1092 -- outside the protected object.
1097 (External_Subprogram
1098 (Entity
(Selector_Name
(Pref
))), Loc
);
1101 Make_Attribute_Reference
(Loc
,
1102 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1103 Attribute_Name
=> Name_Address
);
1106 if Has_By_Protected_Procedure_Prefixed_View
then
1108 Ctrl_Tag
: Node_Id
:= Duplicate_Subexpr
(Prefix
(Pref
));
1109 Prim_Addr
: Node_Id
;
1110 Subp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
1111 Typ
: constant Entity_Id
:=
1112 Etype
(Etype
(Entity
(Prefix
(Pref
))));
1114 -- The target subprogram is a thunk; retrieve its address from
1115 -- its secondary dispatch table slot.
1117 Build_Get_Prim_Op_Address
(Loc
,
1119 Tag_Node
=> Ctrl_Tag
,
1120 Position
=> DT_Position
(Subp
),
1121 New_Node
=> Prim_Addr
);
1123 -- Mark the access to the target subprogram as an access to the
1124 -- dispatch table and perform an unchecked type conversion to such
1125 -- access type. This is required to allow the backend to properly
1126 -- identify and handle the access to the dispatch table slot on
1127 -- targets where the dispatch table contains descriptors (instead
1130 Set_Is_Dispatch_Table_Entity
(Acc
);
1131 Sub_Ref
:= Unchecked_Convert_To
(Acc
, Prim_Addr
);
1135 Make_Aggregate
(Loc
,
1136 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1143 Make_Attribute_Reference
(Loc
,
1145 Attribute_Name
=> Name_Access
);
1147 -- We set the type of the access reference to the already generated
1148 -- access_to_subprogram type, and declare the reference analyzed,
1149 -- to prevent further expansion when the enclosing aggregate is
1152 Set_Etype
(Sub_Ref
, Acc
);
1153 Set_Analyzed
(Sub_Ref
);
1156 Make_Aggregate
(Loc
,
1157 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1159 -- Sub_Ref has been marked as analyzed, but we still need to make
1160 -- sure Sub is correctly frozen.
1162 Freeze_Before
(N
, Entity
(Sub
));
1166 Analyze_And_Resolve
(N
, E_T
);
1168 -- For subsequent analysis, the node must retain its type. The backend
1169 -- will replace it with the equivalent type where needed.
1172 end Expand_Access_To_Protected_Op
;
1174 --------------------------
1175 -- Expand_Fpt_Attribute --
1176 --------------------------
1178 procedure Expand_Fpt_Attribute
1184 Loc
: constant Source_Ptr
:= Sloc
(N
);
1185 Typ
: constant Entity_Id
:= Etype
(N
);
1189 -- The function name is the selected component Attr_xxx.yyy where
1190 -- Attr_xxx is the package name, and yyy is the argument Nam.
1192 -- Note: it would be more usual to have separate RE entries for each
1193 -- of the entities in the Fat packages, but first they have identical
1194 -- names (so we would have to have lots of renaming declarations to
1195 -- meet the normal RE rule of separate names for all runtime entities),
1196 -- and second there would be an awful lot of them.
1199 Make_Selected_Component
(Loc
,
1200 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
1201 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
1203 -- The generated call is given the provided set of parameters, and then
1204 -- wrapped in a conversion which converts the result to the target type.
1208 Make_Function_Call
(Loc
,
1210 Parameter_Associations
=> Args
)));
1212 Analyze_And_Resolve
(N
, Typ
);
1213 end Expand_Fpt_Attribute
;
1215 ----------------------------
1216 -- Expand_Fpt_Attribute_R --
1217 ----------------------------
1219 -- The single argument is converted to its root type to call the
1220 -- appropriate runtime function, with the actual call being built
1221 -- by Expand_Fpt_Attribute
1223 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
1224 E1
: constant Node_Id
:= First
(Expressions
(N
));
1228 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1229 Expand_Fpt_Attribute
1230 (N
, Pkg
, Attribute_Name
(N
),
1231 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
1232 end Expand_Fpt_Attribute_R
;
1234 -----------------------------
1235 -- Expand_Fpt_Attribute_RI --
1236 -----------------------------
1238 -- The first argument is converted to its root type and the second
1239 -- argument is converted to standard long long integer to call the
1240 -- appropriate runtime function, with the actual call being built
1241 -- by Expand_Fpt_Attribute
1243 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
1244 E1
: constant Node_Id
:= First
(Expressions
(N
));
1245 E2
: constant Node_Id
:= Next
(E1
);
1249 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1250 Expand_Fpt_Attribute
1251 (N
, Pkg
, Attribute_Name
(N
),
1253 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1254 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
1255 end Expand_Fpt_Attribute_RI
;
1257 -----------------------------
1258 -- Expand_Fpt_Attribute_RR --
1259 -----------------------------
1261 -- The two arguments are converted to their root types to call the
1262 -- appropriate runtime function, with the actual call being built
1263 -- by Expand_Fpt_Attribute
1265 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
1266 E1
: constant Node_Id
:= First
(Expressions
(N
));
1267 E2
: constant Node_Id
:= Next
(E1
);
1272 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1273 Expand_Fpt_Attribute
1274 (N
, Pkg
, Attribute_Name
(N
),
1276 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1277 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
1278 end Expand_Fpt_Attribute_RR
;
1280 ---------------------------------
1281 -- Expand_Loop_Entry_Attribute --
1282 ---------------------------------
1284 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
1285 procedure Build_Conditional_Block
1288 Loop_Stmt
: Node_Id
;
1289 If_Stmt
: out Node_Id
;
1290 Blk_Stmt
: out Node_Id
);
1291 -- Create a block Blk_Stmt with an empty declarative list and a single
1292 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1293 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1295 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
1296 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1299 -----------------------------
1300 -- Build_Conditional_Block --
1301 -----------------------------
1303 procedure Build_Conditional_Block
1306 Loop_Stmt
: Node_Id
;
1307 If_Stmt
: out Node_Id
;
1308 Blk_Stmt
: out Node_Id
)
1311 -- Do not reanalyze the original loop statement because it is simply
1314 Set_Analyzed
(Loop_Stmt
);
1317 Make_Block_Statement
(Loc
,
1318 Declarations
=> New_List
,
1319 Handled_Statement_Sequence
=>
1320 Make_Handled_Sequence_Of_Statements
(Loc
,
1321 Statements
=> New_List
(Loop_Stmt
)));
1323 if Present
(Cond
) then
1325 Make_If_Statement
(Loc
,
1327 Then_Statements
=> New_List
(Blk_Stmt
));
1331 end Build_Conditional_Block
;
1333 ------------------------
1334 -- Is_Array_Iteration --
1335 ------------------------
1337 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1338 Stmt
: constant Node_Id
:= Original_Node
(N
);
1342 if Nkind
(Stmt
) = N_Loop_Statement
1343 and then Present
(Iteration_Scheme
(Stmt
))
1344 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1346 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1349 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1353 end Is_Array_Iteration
;
1357 Pref
: constant Node_Id
:= Prefix
(N
);
1358 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1359 Exprs
: constant List_Id
:= Expressions
(N
);
1361 Blk
: Node_Id
:= Empty
;
1363 Installed
: Boolean;
1365 Loop_Id
: Entity_Id
;
1366 Loop_Stmt
: Node_Id
;
1367 Result
: Node_Id
:= Empty
;
1369 Temp_Decl
: Node_Id
;
1370 Temp_Id
: Entity_Id
;
1372 -- Start of processing for Expand_Loop_Entry_Attribute
1375 -- Step 1: Find the related loop
1377 -- The loop label variant of attribute 'Loop_Entry already has all the
1378 -- information in its expression.
1380 if Present
(Exprs
) then
1381 Loop_Id
:= Entity
(First
(Exprs
));
1382 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1384 -- Climb the parent chain to find the nearest enclosing loop. Skip
1385 -- all internally generated loops for quantified expressions and for
1386 -- element iterators over multidimensional arrays because the pragma
1387 -- applies to source loop.
1391 while Present
(Loop_Stmt
) loop
1392 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1393 and then Nkind
(Original_Node
(Loop_Stmt
)) = N_Loop_Statement
1394 and then Comes_From_Source
(Original_Node
(Loop_Stmt
))
1399 Loop_Stmt
:= Parent
(Loop_Stmt
);
1402 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1405 Loc
:= Sloc
(Loop_Stmt
);
1407 -- Step 2: Transform the loop
1409 -- The loop has already been transformed during the expansion of a prior
1410 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1412 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1414 -- When the related loop name appears as the argument of attribute
1415 -- Loop_Entry, the corresponding label construct is the generated
1416 -- block statement. This is because the expander reuses the label.
1418 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1419 Decls
:= Declarations
(Loop_Stmt
);
1421 -- In all other cases, the loop must appear in the handled sequence
1422 -- of statements of the generated block.
1426 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1428 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1430 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1433 -- Transform the loop into a conditional block
1436 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1437 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1439 -- Infinite loops are transformed into:
1442 -- Temp1 : constant <type of Pref1> := <Pref1>;
1444 -- TempN : constant <type of PrefN> := <PrefN>;
1447 -- <original source statements with attribute rewrites>
1452 Build_Conditional_Block
(Loc
,
1454 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1460 -- While loops are transformed into:
1462 -- function Fnn return Boolean is
1464 -- <condition actions>
1465 -- return <condition>;
1470 -- Temp1 : constant <type of Pref1> := <Pref1>;
1472 -- TempN : constant <type of PrefN> := <PrefN>;
1475 -- <original source statements with attribute rewrites>
1476 -- exit when not Fnn;
1481 -- Note that loops over iterators and containers are already
1482 -- converted into while loops.
1484 elsif Present
(Condition
(Scheme
)) then
1486 Func_Decl
: Node_Id
;
1487 Func_Id
: Entity_Id
;
1491 Func_Id
:= Make_Temporary
(Loc
, 'F');
1493 -- Wrap the condition of the while loop in a Boolean function.
1494 -- This avoids the duplication of the same code which may lead
1495 -- to gigi issues with respect to multiple declaration of the
1496 -- same entity in the presence of side effects or checks. Note
1497 -- that the condition actions must also be relocated into the
1498 -- wrapping function because they may contain itypes, e.g. in
1499 -- the case of a comparison involving slices.
1502 -- <condition actions>
1503 -- return <condition>;
1505 if Present
(Condition_Actions
(Scheme
)) then
1506 Stmts
:= Condition_Actions
(Scheme
);
1512 Make_Simple_Return_Statement
(Loc
,
1514 New_Copy_Tree
(Condition
(Scheme
),
1515 New_Scope
=> Func_Id
)));
1518 -- function Fnn return Boolean is
1524 Make_Subprogram_Body
(Loc
,
1526 Make_Function_Specification
(Loc
,
1527 Defining_Unit_Name
=> Func_Id
,
1528 Result_Definition
=>
1529 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1530 Declarations
=> Empty_List
,
1531 Handled_Statement_Sequence
=>
1532 Make_Handled_Sequence_Of_Statements
(Loc
,
1533 Statements
=> Stmts
));
1535 -- The function is inserted before the related loop. Make sure
1536 -- to analyze it in the context of the loop's enclosing scope.
1538 Push_Scope
(Scope
(Loop_Id
));
1539 Insert_Action
(Loop_Stmt
, Func_Decl
);
1542 -- The analysis of the condition may have generated entities
1543 -- (such as itypes) that are now used within the function.
1544 -- Adjust their scopes accordingly so that their use appears
1545 -- in their scope of definition.
1551 Ent
:= First_Entity
(Loop_Id
);
1553 while Present
(Ent
) loop
1554 -- Various entities that now occur within the function
1555 -- need to have their scope reset, but not all entities
1556 -- associated with Loop_Id are now inside the function.
1557 -- The function entity itself and loop parameters can
1558 -- be outside the function, and there may be others.
1559 -- It's not clear how the determination of what entity
1560 -- scopes need to be adjusted can be made accurately.
1561 -- Perhaps it will be necessary to traverse the function
1562 -- body to find the exact entities whose scopes need to
1563 -- be reset to the function's Entity_Id. ???
1565 if Ekind
(Ent
) /= E_Loop_Parameter
1566 and then Ent
/= Func_Id
1568 Set_Scope
(Ent
, Func_Id
);
1575 -- Transform the original while loop into an infinite loop
1576 -- where the last statement checks the negated condition. This
1577 -- placement ensures that the condition will not be evaluated
1578 -- twice on the first iteration.
1580 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1584 -- exit when not Fnn;
1586 Append_To
(Statements
(Loop_Stmt
),
1587 Make_Exit_Statement
(Loc
,
1591 Make_Function_Call
(Loc
,
1592 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1594 Build_Conditional_Block
(Loc
,
1596 Make_Function_Call
(Loc
,
1597 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1598 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1603 -- Ada 2012 iteration over an array is transformed into:
1605 -- if <Array_Nam>'Length (1) > 0
1606 -- and then <Array_Nam>'Length (N) > 0
1609 -- Temp1 : constant <type of Pref1> := <Pref1>;
1611 -- TempN : constant <type of PrefN> := <PrefN>;
1613 -- for X in ... loop -- multiple loops depending on dims
1614 -- <original source statements with attribute rewrites>
1619 elsif Is_Array_Iteration
(Loop_Stmt
) then
1621 Array_Nam
: constant Entity_Id
:=
1622 Entity
(Name
(Iterator_Specification
1623 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1624 Num_Dims
: constant Pos
:=
1625 Number_Dimensions
(Etype
(Array_Nam
));
1626 Cond
: Node_Id
:= Empty
;
1630 -- Generate a check which determines whether all dimensions of
1631 -- the array are non-null.
1633 for Dim
in 1 .. Num_Dims
loop
1637 Make_Attribute_Reference
(Loc
,
1638 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1639 Attribute_Name
=> Name_Length
,
1640 Expressions
=> New_List
(
1641 Make_Integer_Literal
(Loc
, Dim
))),
1643 Make_Integer_Literal
(Loc
, 0));
1651 Right_Opnd
=> Check
);
1655 Build_Conditional_Block
(Loc
,
1657 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1662 -- For loops are transformed into:
1664 -- if <Low> <= <High> then
1666 -- Temp1 : constant <type of Pref1> := <Pref1>;
1668 -- TempN : constant <type of PrefN> := <PrefN>;
1670 -- for <Def_Id> in <Low> .. <High> loop
1671 -- <original source statements with attribute rewrites>
1676 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1678 Loop_Spec
: constant Node_Id
:=
1679 Loop_Parameter_Specification
(Scheme
);
1684 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1686 -- When the loop iterates over a subtype indication with a
1687 -- range, use the low and high bounds of the subtype itself.
1689 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1690 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1693 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1700 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1701 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1703 Build_Conditional_Block
(Loc
,
1705 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1711 Decls
:= Declarations
(Blk
);
1714 -- Step 3: Create a constant to capture the value of the prefix at the
1715 -- entry point into the loop.
1717 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1719 -- Preserve the tag of the prefix by offering a specific view of the
1720 -- class-wide version of the prefix.
1722 if Is_Tagged_Type
(Base_Typ
) then
1723 Tagged_Case
: declare
1724 CW_Temp
: Entity_Id
;
1729 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1731 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1732 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1735 Make_Object_Declaration
(Loc
,
1736 Defining_Identifier
=> CW_Temp
,
1737 Constant_Present
=> True,
1738 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1740 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1741 Append_To
(Decls
, Aux_Decl
);
1744 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1747 Make_Object_Renaming_Declaration
(Loc
,
1748 Defining_Identifier
=> Temp_Id
,
1749 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1751 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1752 Append_To
(Decls
, Temp_Decl
);
1758 Untagged_Case
: declare
1759 Temp_Expr
: Node_Id
;
1764 -- Generate a nominal type for the constant when the prefix is of
1765 -- a constrained type. This is achieved by setting the Etype of
1766 -- the relocated prefix to its base type. Since the prefix is now
1767 -- the initialization expression of the constant, its freezing
1768 -- will produce a proper nominal type.
1770 Temp_Expr
:= Relocate_Node
(Pref
);
1771 Set_Etype
(Temp_Expr
, Base_Typ
);
1774 -- Temp : constant Base_Typ := Pref;
1777 Make_Object_Declaration
(Loc
,
1778 Defining_Identifier
=> Temp_Id
,
1779 Constant_Present
=> True,
1780 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1781 Expression
=> Temp_Expr
);
1782 Append_To
(Decls
, Temp_Decl
);
1786 -- Step 4: Analyze all bits
1788 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1790 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1791 -- associated loop, ensure the proper visibility for analysis.
1793 if not Installed
then
1794 Push_Scope
(Scope
(Loop_Id
));
1797 -- Analyze constant declaration with simple value propagation disabled,
1798 -- because the values at the loop entry might be different than the
1799 -- values at the occurrence of Loop_Entry attribute.
1802 Save_Debug_Flag_MM
: constant Boolean := Debug_Flag_MM
;
1804 Debug_Flag_MM
:= True;
1806 if Present
(Aux_Decl
) then
1810 Analyze
(Temp_Decl
);
1812 Debug_Flag_MM
:= Save_Debug_Flag_MM
;
1815 -- If the conditional block has just been created, then analyze it;
1816 -- otherwise it was analyzed when a previous 'Loop_Entry was expanded.
1818 if Present
(Result
) then
1819 Rewrite
(Loop_Stmt
, Result
);
1820 Analyze
(Loop_Stmt
);
1823 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1826 if not Installed
then
1829 end Expand_Loop_Entry_Attribute
;
1831 ------------------------------
1832 -- Expand_Min_Max_Attribute --
1833 ------------------------------
1835 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1837 -- Min and Max are handled by the back end (except that static cases
1838 -- have already been evaluated during semantic processing, although the
1839 -- back end should not count on this). The one bit of special processing
1840 -- required in the normal case is that these two attributes typically
1841 -- generate conditionals in the code, so check the relevant restriction.
1843 Check_Restriction
(No_Implicit_Conditionals
, N
);
1844 end Expand_Min_Max_Attribute
;
1846 ----------------------------------
1847 -- Expand_N_Attribute_Reference --
1848 ----------------------------------
1850 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1851 Loc
: constant Source_Ptr
:= Sloc
(N
);
1852 Pref
: constant Node_Id
:= Prefix
(N
);
1853 Exprs
: constant List_Id
:= Expressions
(N
);
1855 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
;
1856 -- Return a small integer type appropriate for the enumeration type
1858 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
);
1859 -- Rewrites an attribute for Read, Write, Output, or Put_Image with a
1860 -- call to the appropriate TSS procedure. Pname is the entity for the
1861 -- procedure to call.
1863 ----------------------
1864 -- Get_Integer_Type --
1865 ----------------------
1867 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
is
1868 Siz
: constant Uint
:= Esize
(Base_Type
(Typ
));
1871 -- We need to accommodate invalid values of the base type since we
1872 -- accept them for Enum_Rep and Pos, so we reason on the Esize.
1874 return Small_Integer_Type_For
(Siz
, Uns
=> Is_Unsigned_Type
(Typ
));
1875 end Get_Integer_Type
;
1877 ---------------------------------
1878 -- Rewrite_Attribute_Proc_Call --
1879 ---------------------------------
1881 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
) is
1882 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1883 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1884 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1885 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1886 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1889 -- The expansion depends on Item, the second actual, which is
1890 -- the object being streamed in or out.
1892 -- If the item is a component of a packed array type, and
1893 -- a conversion is needed on exit, we introduce a temporary to
1894 -- hold the value, because otherwise the packed reference will
1895 -- not be properly expanded.
1897 if Nkind
(Item
) = N_Indexed_Component
1898 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1899 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1903 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1909 Make_Object_Declaration
(Loc
,
1910 Defining_Identifier
=> Temp
,
1911 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1912 Set_Etype
(Temp
, Formal_Typ
);
1915 Make_Assignment_Statement
(Loc
,
1916 Name
=> New_Copy_Tree
(Item
),
1918 Unchecked_Convert_To
1919 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1921 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1925 Make_Procedure_Call_Statement
(Loc
,
1926 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1927 Parameter_Associations
=> Exprs
),
1930 Rewrite
(N
, Make_Null_Statement
(Loc
));
1935 -- For the class-wide dispatching cases, and for cases in which
1936 -- the base type of the second argument matches the base type of
1937 -- the corresponding formal parameter (that is to say the stream
1938 -- operation is not inherited), we are all set, and can use the
1939 -- argument unchanged.
1941 if not Is_Class_Wide_Type
(Entity
(Pref
))
1942 and then not Is_Class_Wide_Type
(Etype
(Item
))
1943 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1945 -- Perform a view conversion when either the argument or the
1946 -- formal parameter are of a private type.
1948 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1949 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1952 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1954 -- Otherwise perform a regular type conversion to ensure that all
1955 -- relevant checks are installed.
1958 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1961 -- For untagged derived types set Assignment_OK, to prevent
1962 -- copies from being created when the unchecked conversion
1963 -- is expanded (which would happen in Remove_Side_Effects
1964 -- if Expand_N_Unchecked_Conversion were allowed to call
1965 -- Force_Evaluation). The copy could violate Ada semantics in
1966 -- cases such as an actual that is an out parameter. Note that
1967 -- this approach is also used in exp_ch7 for calls to controlled
1968 -- type operations to prevent problems with actuals wrapped in
1969 -- unchecked conversions.
1971 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1972 Set_Assignment_OK
(Item
);
1976 -- The stream operation to call might be a renaming created by an
1977 -- attribute definition clause, and might not be frozen yet. Ensure
1978 -- that it has the necessary extra formals.
1980 if not Is_Frozen
(Pname
) then
1981 Create_Extra_Formals
(Pname
);
1984 -- And now rewrite the call
1987 Make_Procedure_Call_Statement
(Loc
,
1988 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1989 Parameter_Associations
=> Exprs
));
1992 end Rewrite_Attribute_Proc_Call
;
1994 Typ
: constant Entity_Id
:= Etype
(N
);
1995 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1996 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1997 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1999 -- Start of processing for Expand_N_Attribute_Reference
2002 -- Do required validity checking, if enabled.
2004 -- Skip check for output parameters of an Asm instruction (since their
2005 -- valuesare not set till after the attribute has been elaborated),
2006 -- for the arguments of a 'Read attribute reference (since the
2007 -- scalar argument is an OUT scalar) and for the arguments of a
2008 -- 'Has_Same_Storage or 'Overlaps_Storage attribute reference (which not
2009 -- considered to be reads of their prefixes and expressions, see Ada RM
2012 if Validity_Checks_On
and then Validity_Check_Operands
2013 and then Id
/= Attribute_Asm_Output
2014 and then Id
/= Attribute_Read
2015 and then Id
/= Attribute_Has_Same_Storage
2016 and then Id
/= Attribute_Overlaps_Storage
2021 Expr
:= First
(Expressions
(N
));
2022 while Present
(Expr
) loop
2023 Ensure_Valid
(Expr
);
2029 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
2030 -- place function, then a temporary return object needs to be created
2031 -- and access to it must be passed to the function.
2033 if Is_Build_In_Place_Function_Call
(Pref
) then
2035 -- If attribute is 'Old, the context is a postcondition, and
2036 -- the temporary must go in the corresponding subprogram, not
2037 -- the postcondition function or any created blocks, as when
2038 -- the attribute appears in a quantified expression. This is
2039 -- handled below in the expansion of the attribute.
2041 if Attribute_Name
(Parent
(Pref
)) = Name_Old
then
2044 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
2047 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
2048 -- containing build-in-place function calls whose returned object covers
2051 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
2052 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
2055 -- If prefix is a protected type name, this is a reference to the
2056 -- current instance of the type. For a component definition, nothing
2057 -- to do (expansion will occur in the init proc). In other contexts,
2058 -- rewrite into reference to current instance.
2060 if Is_Protected_Self_Reference
(Pref
)
2062 (Nkind
(Parent
(N
)) in N_Index_Or_Discriminant_Constraint
2063 | N_Discriminant_Association
2064 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
2065 N_Component_Definition
)
2067 -- No action needed for these attributes since the current instance
2068 -- will be rewritten to be the name of the _object parameter
2069 -- associated with the enclosing protected subprogram (see below).
2071 and then Id
/= Attribute_Access
2072 and then Id
/= Attribute_Unchecked_Access
2073 and then Id
/= Attribute_Unrestricted_Access
2075 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
2079 -- Remaining processing depends on specific attribute
2081 -- Note: individual sections of the following case statement are
2082 -- allowed to assume there is no code after the case statement, and
2083 -- are legitimately allowed to execute return statements if they have
2084 -- nothing more to do.
2088 -- Attributes related to Ada 2012 iterators. They are only allowed in
2089 -- attribute definition clauses and should never be expanded.
2091 when Attribute_Constant_Indexing
2092 | Attribute_Default_Iterator
2093 | Attribute_Implicit_Dereference
2094 | Attribute_Iterable
2095 | Attribute_Iterator_Element
2096 | Attribute_Variable_Indexing
2098 raise Program_Error
;
2100 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2101 -- were already rejected by the parser. Thus they shouldn't appear here.
2103 when Internal_Attribute_Id
=>
2104 raise Program_Error
;
2110 when Attribute_Access
2111 | Attribute_Unchecked_Access
2112 | Attribute_Unrestricted_Access
2114 Access_Cases
: declare
2115 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
2116 Btyp_DDT
: Entity_Id
;
2118 procedure Add_Implicit_Interface_Type_Conversion
;
2119 -- Ada 2005 (AI-251): The designated type is an interface type;
2120 -- add an implicit type conversion to force the displacement of
2121 -- the pointer to reference the secondary dispatch table.
2123 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
2124 -- If N denotes a compound name (selected component, indexed
2125 -- component, or slice), returns the name of the outermost such
2126 -- enclosing object. Otherwise returns N. If the object is a
2127 -- renaming, then the renamed object is returned.
2129 --------------------------------------------
2130 -- Add_Implicit_Interface_Type_Conversion --
2131 --------------------------------------------
2133 procedure Add_Implicit_Interface_Type_Conversion
is
2135 pragma Assert
(Is_Interface
(Btyp_DDT
));
2137 -- Handle cases were no action is required.
2139 if not Comes_From_Source
(N
)
2140 and then not Comes_From_Source
(Ref_Object
)
2141 and then (Nkind
(Ref_Object
) not in N_Has_Chars
2142 or else Chars
(Ref_Object
) /= Name_uInit
)
2149 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2151 -- No implicit conversion required if types match, or if
2152 -- the prefix is the class_wide_type of the interface. In
2153 -- either case passing an object of the interface type has
2154 -- already set the pointer correctly.
2156 if Btyp_DDT
= Etype
(Ref_Object
)
2158 (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2160 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2165 Rewrite
(Prefix
(N
),
2166 Convert_To
(Btyp_DDT
,
2167 New_Copy_Tree
(Prefix
(N
))));
2169 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2172 -- When the object is an explicit dereference, convert the
2173 -- dereference's prefix.
2177 Obj_DDT
: constant Entity_Id
:=
2179 (Directly_Designated_Type
2180 (Etype
(Prefix
(Ref_Object
))));
2182 -- No implicit conversion required if designated types
2185 if Obj_DDT
/= Btyp_DDT
2186 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2187 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2191 New_Copy_Tree
(Prefix
(Ref_Object
))));
2192 Analyze_And_Resolve
(N
, Typ
);
2196 end Add_Implicit_Interface_Type_Conversion
;
2198 ----------------------
2199 -- Enclosing_Object --
2200 ----------------------
2202 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
2207 while Nkind
(Obj_Name
) in N_Selected_Component
2208 | N_Indexed_Component
2211 Obj_Name
:= Prefix
(Obj_Name
);
2214 return Get_Referenced_Object
(Obj_Name
);
2215 end Enclosing_Object
;
2217 -- Local declarations
2219 Enc_Object
: Node_Id
:= Enclosing_Object
(Ref_Object
);
2221 -- Start of processing for Access_Cases
2224 Btyp_DDT
:= Designated_Type
(Btyp
);
2226 -- When Enc_Object is a view conversion then RM 3.10.2 (9)
2227 -- applies and we obtain the expression being converted.
2228 -- Otherwise we do not dig any deeper since a conversion
2229 -- might generate a copy and we can't assume it will be as
2230 -- long-lived as the original.
2232 while Nkind
(Enc_Object
) = N_Type_Conversion
2233 and then Is_View_Conversion
(Enc_Object
)
2235 Enc_Object
:= Expression
(Enc_Object
);
2238 -- Handle designated types that come from the limited view
2240 if From_Limited_With
(Btyp_DDT
)
2241 and then Has_Non_Limited_View
(Btyp_DDT
)
2243 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
2246 -- In order to improve the text of error messages, the designated
2247 -- type of access-to-subprogram itypes is set by the semantics as
2248 -- the associated subprogram entity (see sem_attr). Now we replace
2249 -- such node with the proper E_Subprogram_Type itype.
2251 if Id
= Attribute_Unrestricted_Access
2252 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
2254 -- The following conditions ensure that this special management
2255 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2256 -- At this stage other cases in which the designated type is
2257 -- still a subprogram (instead of an E_Subprogram_Type) are
2258 -- wrong because the semantics must have overridden the type of
2259 -- the node with the type imposed by the context.
2261 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
2262 and then Is_RTE
(Etype
(Parent
(N
)), RE_Prim_Ptr
)
2264 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
2268 Subp
: constant Entity_Id
:=
2269 Directly_Designated_Type
(Typ
);
2271 Extra
: Entity_Id
:= Empty
;
2272 New_Formal
: Entity_Id
;
2273 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
2274 Subp_Typ
: Entity_Id
;
2277 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
2278 Copy_Strub_Mode
(Subp_Typ
, Subp
);
2279 Set_Etype
(Subp_Typ
, Etype
(Subp
));
2280 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
2282 if Present
(Old_Formal
) then
2283 New_Formal
:= New_Copy
(Old_Formal
);
2284 Set_First_Entity
(Subp_Typ
, New_Formal
);
2287 Set_Scope
(New_Formal
, Subp_Typ
);
2288 Etyp
:= Etype
(New_Formal
);
2290 -- Handle itypes. There is no need to duplicate
2291 -- here the itypes associated with record types
2292 -- (i.e the implicit full view of private types).
2295 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
2297 Extra
:= New_Copy
(Etyp
);
2298 Set_Parent
(Extra
, New_Formal
);
2299 Set_Etype
(New_Formal
, Extra
);
2300 Set_Scope
(Extra
, Subp_Typ
);
2303 Extra
:= New_Formal
;
2304 Next_Formal
(Old_Formal
);
2305 exit when No
(Old_Formal
);
2307 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
2308 Next_Entity
(New_Formal
);
2311 Unlink_Next_Entity
(New_Formal
);
2312 Set_Last_Entity
(Subp_Typ
, Extra
);
2315 -- Now that the explicit formals have been duplicated,
2316 -- any extra formals needed by the subprogram must be
2319 if Present
(Extra
) then
2320 Set_Extra_Formal
(Extra
, Empty
);
2323 Create_Extra_Formals
(Subp_Typ
);
2324 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
2329 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
2330 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
2332 elsif Is_Access_Subprogram_Type
(Btyp
)
2333 and then Is_Entity_Name
(Pref
)
2335 -- If prefix is a subprogram that has class-wide preconditions
2336 -- and an indirect-call wrapper (ICW) of the subprogram is
2337 -- available then replace the prefix by the ICW.
2339 if Present
(Class_Preconditions
(Entity
(Pref
)))
2340 and then Present
(Indirect_Call_Wrapper
(Entity
(Pref
)))
2344 (Indirect_Call_Wrapper
(Entity
(Pref
)), Loc
));
2345 Analyze_And_Resolve
(N
, Typ
);
2348 -- Ensure the availability of the extra formals to check that
2351 if not Is_Frozen
(Entity
(Pref
))
2352 or else From_Limited_With
(Etype
(Entity
(Pref
)))
2354 Create_Extra_Formals
(Entity
(Pref
));
2357 if not Is_Frozen
(Btyp_DDT
)
2358 or else From_Limited_With
(Etype
(Btyp_DDT
))
2360 Create_Extra_Formals
(Btyp_DDT
);
2364 (Extra_Formals_Match_OK
2365 (E
=> Entity
(Pref
), Ref_E
=> Btyp_DDT
));
2367 -- If prefix is a type name, this is a reference to the current
2368 -- instance of the type, within its initialization procedure.
2370 elsif Is_Entity_Name
(Pref
)
2371 and then Is_Type
(Entity
(Pref
))
2378 -- If the current instance name denotes a task type, then
2379 -- the access attribute is rewritten to be the name of the
2380 -- "_task" parameter associated with the task type's task
2381 -- procedure. An unchecked conversion is applied to ensure
2382 -- a type match in cases of expander-generated calls (e.g.
2385 if Is_Task_Type
(Entity
(Pref
)) then
2387 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
2388 while Present
(Formal
) loop
2389 exit when Chars
(Formal
) = Name_uTask
;
2390 Next_Entity
(Formal
);
2393 pragma Assert
(Present
(Formal
));
2396 Unchecked_Convert_To
(Typ
,
2397 New_Occurrence_Of
(Formal
, Loc
)));
2400 elsif Is_Protected_Type
(Entity
(Pref
)) then
2402 -- No action needed for current instance located in a
2403 -- component definition (expansion will occur in the
2406 if Is_Protected_Type
(Current_Scope
) then
2409 -- If the current instance reference is located in a
2410 -- protected subprogram or entry then rewrite the access
2411 -- attribute to be the name of the "_object" parameter.
2412 -- An unchecked conversion is applied to ensure a type
2413 -- match in cases of expander-generated calls (e.g. init
2416 -- The code may be nested in a block, so find enclosing
2417 -- scope that is a protected operation.
2424 Subp
:= Current_Scope
;
2425 while Ekind
(Subp
) in E_Loop | E_Block
loop
2426 Subp
:= Scope
(Subp
);
2431 (Protected_Body_Subprogram
(Subp
));
2433 -- For a protected subprogram the _Object parameter
2434 -- is the protected record, so we create an access
2435 -- to it. The _Object parameter of an entry is an
2438 if Ekind
(Subp
) = E_Entry
then
2440 Unchecked_Convert_To
(Typ
,
2441 New_Occurrence_Of
(Formal
, Loc
)));
2446 Unchecked_Convert_To
(Typ
,
2447 Make_Attribute_Reference
(Loc
,
2448 Attribute_Name
=> Name_Unrestricted_Access
,
2450 New_Occurrence_Of
(Formal
, Loc
))));
2451 Analyze_And_Resolve
(N
);
2456 -- The expression must appear in a default expression,
2457 -- (which in the initialization procedure is the right-hand
2458 -- side of an assignment), and not in a discriminant
2463 while Present
(Par
) loop
2464 exit when Nkind
(Par
) = N_Assignment_Statement
;
2466 if Nkind
(Par
) = N_Component_Declaration
then
2470 Par
:= Parent
(Par
);
2473 if Present
(Par
) then
2475 Make_Attribute_Reference
(Loc
,
2476 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2477 Attribute_Name
=> Attribute_Name
(N
)));
2479 Analyze_And_Resolve
(N
, Typ
);
2484 -- If the prefix of an Access attribute is a dereference of an
2485 -- access parameter (or a renaming of such a dereference, or a
2486 -- subcomponent of such a dereference) and the context is a
2487 -- general access type (including the type of an object or
2488 -- component with an access_definition, but not the anonymous
2489 -- type of an access parameter or access discriminant), then
2490 -- apply an accessibility check to the access parameter. We used
2491 -- to rewrite the access parameter as a type conversion, but that
2492 -- could only be done if the immediate prefix of the Access
2493 -- attribute was the dereference, and didn't handle cases where
2494 -- the attribute is applied to a subcomponent of the dereference,
2495 -- since there's generally no available, appropriate access type
2496 -- to convert to in that case. The attribute is passed as the
2497 -- point to insert the check, because the access parameter may
2498 -- come from a renaming, possibly in a different scope, and the
2499 -- check must be associated with the attribute itself.
2501 elsif Id
= Attribute_Access
2502 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2503 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2504 and then (Ekind
(Btyp
) = E_General_Access_Type
2505 or else Is_Local_Anonymous_Access
(Btyp
))
2506 and then Is_Formal
(Entity
(Prefix
(Enc_Object
)))
2507 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2508 = E_Anonymous_Access_Type
2509 and then Present
(Extra_Accessibility
2510 (Entity
(Prefix
(Enc_Object
))))
2511 and then not No_Dynamic_Accessibility_Checks_Enabled
(Enc_Object
)
2513 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2515 -- Ada 2005 (AI-251): If the designated type is an interface we
2516 -- add an implicit conversion to force the displacement of the
2517 -- pointer to reference the secondary dispatch table.
2519 if Is_Interface
(Btyp_DDT
) then
2520 Add_Implicit_Interface_Type_Conversion
;
2523 -- Ada 2005 (AI-251): If the designated type is an interface we
2524 -- add an implicit conversion to force the displacement of the
2525 -- pointer to reference the secondary dispatch table.
2527 elsif Is_Interface
(Btyp_DDT
) then
2528 Add_Implicit_Interface_Type_Conversion
;
2536 -- Transforms 'Adjacent into a call to the floating-point attribute
2537 -- function Adjacent in Fat_xxx (where xxx is the root type)
2539 when Attribute_Adjacent
=>
2540 Expand_Fpt_Attribute_RR
(N
);
2546 when Attribute_Address
=> Address
: declare
2547 Task_Proc
: Entity_Id
;
2549 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean;
2550 -- Returns True if N is being used to initialize a component of
2551 -- an activation record object where the component corresponds to
2552 -- the object denoted by the prefix of the attribute N.
2554 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean is
2556 return Present
(Parent
(N
))
2557 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2558 and then Is_Entity_Name
(Pref
)
2559 and then Present
(Activation_Record_Component
(Entity
(Pref
)))
2560 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2561 and then Entity
(Selector_Name
(Name
(Parent
(N
)))) =
2562 Activation_Record_Component
(Entity
(Pref
));
2563 end Is_Unnested_Component_Init
;
2565 -- Start of processing for Address
2568 -- If the prefix is a task or a task type, the useful address is that
2569 -- of the procedure for the task body, i.e. the actual program unit.
2570 -- We replace the original entity with that of the procedure.
2572 if Is_Entity_Name
(Pref
)
2573 and then Is_Task_Type
(Entity
(Pref
))
2575 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2577 while Present
(Task_Proc
) loop
2578 exit when Ekind
(Task_Proc
) = E_Procedure
2579 and then Etype
(First_Formal
(Task_Proc
)) =
2580 Corresponding_Record_Type
(Ptyp
);
2581 Next_Entity
(Task_Proc
);
2584 if Present
(Task_Proc
) then
2585 Set_Entity
(Pref
, Task_Proc
);
2586 Set_Etype
(Pref
, Etype
(Task_Proc
));
2589 -- Similarly, the address of a protected operation is the address
2590 -- of the corresponding protected body, regardless of the protected
2591 -- object from which it is selected.
2593 elsif Nkind
(Pref
) = N_Selected_Component
2594 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2595 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2599 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2601 elsif Nkind
(Pref
) = N_Explicit_Dereference
2602 and then Ekind
(Ptyp
) = E_Subprogram_Type
2603 and then Convention
(Ptyp
) = Convention_Protected
2605 -- The prefix is be a dereference of an access_to_protected_
2606 -- subprogram. The desired address is the second component of
2607 -- the record that represents the access.
2610 Addr
: constant Entity_Id
:= Etype
(N
);
2611 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2612 T
: constant Entity_Id
:=
2613 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2617 Unchecked_Convert_To
(Addr
,
2618 Make_Selected_Component
(Loc
,
2619 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2620 Selector_Name
=> New_Occurrence_Of
(
2621 Next_Entity
(First_Entity
(T
)), Loc
))));
2623 Analyze_And_Resolve
(N
, Addr
);
2626 -- 'Address is an actual parameter of the call to the implicit
2627 -- subprogram To_Pointer instantiated with a class-wide interface
2628 -- type; its expansion requires adding an implicit type conversion
2629 -- to force displacement of the "this" pointer.
2631 elsif Tagged_Type_Expansion
2632 and then Nkind
(Parent
(N
)) = N_Function_Call
2633 and then Nkind
(Name
(Parent
(N
))) in N_Has_Entity
2634 and then Is_Intrinsic_Subprogram
(Entity
(Name
(Parent
(N
))))
2635 and then Chars
(Entity
(Name
(Parent
(N
)))) = Name_To_Pointer
2636 and then Is_Interface
(Designated_Type
(Etype
(Parent
(N
))))
2637 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(Parent
(N
))))
2640 Iface_Typ
: constant Entity_Id
:=
2641 Designated_Type
(Etype
(Parent
(N
)));
2643 Rewrite
(Pref
, Convert_To
(Iface_Typ
, Relocate_Node
(Pref
)));
2644 Analyze_And_Resolve
(Pref
, Iface_Typ
);
2648 -- Ada 2005 (AI-251): Class-wide interface objects are always
2649 -- "displaced" to reference the tag associated with the interface
2650 -- type. In order to obtain the real address of such objects we
2651 -- generate a call to a run-time subprogram that returns the base
2652 -- address of the object. This call is not generated in cases where
2653 -- the attribute is being used to initialize a component of an
2654 -- activation record object where the component corresponds to
2655 -- prefix of the attribute (for back ends that require "unnesting"
2656 -- of nested subprograms), since the address needs to be assigned
2657 -- as-is to such components.
2659 elsif Tagged_Type_Expansion
2660 and then Is_Class_Wide_Type
(Ptyp
)
2661 and then Is_Interface
(Underlying_Type
(Ptyp
))
2662 and then not (Nkind
(Pref
) in N_Has_Entity
2663 and then Is_Subprogram
(Entity
(Pref
)))
2664 and then not Is_Unnested_Component_Init
(N
)
2667 Make_Function_Call
(Loc
,
2668 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2669 Parameter_Associations
=> New_List
(Relocate_Node
(N
))));
2674 -- Deal with packed array reference, other cases are handled by
2677 if Involves_Packed_Array_Reference
(Pref
) then
2678 Expand_Packed_Address_Reference
(N
);
2686 when Attribute_Alignment
=> Alignment
: declare
2690 -- For class-wide types, X'Class'Alignment is transformed into a
2691 -- direct reference to the Alignment of the class type, so that the
2692 -- back end does not have to deal with the X'Class'Alignment
2695 if Is_Entity_Name
(Pref
)
2696 and then Is_Class_Wide_Type
(Entity
(Pref
))
2698 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2701 -- For x'Alignment applied to an object of a class wide type,
2702 -- transform X'Alignment into a call to the predefined primitive
2703 -- operation _Alignment applied to X.
2705 elsif Is_Class_Wide_Type
(Ptyp
) then
2707 Make_Attribute_Reference
(Loc
,
2709 Attribute_Name
=> Name_Tag
);
2711 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2713 -- Case where the context is an unchecked conversion to a specific
2714 -- integer type. We directly convert from the alignment's type.
2716 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
then
2717 Rewrite
(N
, New_Node
);
2718 Analyze_And_Resolve
(N
);
2721 -- Case where the context is a specific integer type with which
2722 -- the original attribute was compatible. But the alignment has a
2723 -- specific type in a-tags.ads (Standard.Natural) so, in order to
2724 -- preserve type compatibility, we must convert explicitly.
2726 elsif Typ
/= Standard_Natural
then
2727 New_Node
:= Convert_To
(Typ
, New_Node
);
2730 Rewrite
(N
, New_Node
);
2731 Analyze_And_Resolve
(N
, Typ
);
2734 -- For all other cases, we just have to deal with the case of
2735 -- the fact that the result can be universal.
2738 Apply_Universal_Integer_Attribute_Checks
(N
);
2742 ---------------------------
2743 -- Asm_Input, Asm_Output --
2744 ---------------------------
2746 -- The Asm_Input and Asm_Output attributes are not expanded at this
2747 -- stage, but will be eliminated in the expansion of the Asm call,
2748 -- see Exp_Intr for details. So the back end will never see them.
2750 when Attribute_Asm_Input
2751 | Attribute_Asm_Output
2759 -- We compute this if a packed array reference was present, otherwise we
2760 -- leave the computation up to the back end.
2762 when Attribute_Bit
=>
2763 if Involves_Packed_Array_Reference
(Pref
) then
2764 Expand_Packed_Bit_Reference
(N
);
2766 Apply_Universal_Integer_Attribute_Checks
(N
);
2773 -- We leave the computation up to the back end, since we don't know what
2774 -- layout will be chosen if no component clause was specified.
2776 when Attribute_Bit_Position
=>
2777 Apply_Universal_Integer_Attribute_Checks
(N
);
2783 -- A reference to P'Body_Version or P'Version is expanded to
2786 -- pragma Import (C, Vnn, "uuuuT");
2788 -- Get_Version_String (Vnn)
2790 -- where uuuu is the unit name (dots replaced by double underscore)
2791 -- and T is B for the cases of Body_Version, or Version applied to a
2792 -- subprogram acting as its own spec, and S for Version applied to a
2793 -- subprogram spec or package. This sequence of code references the
2794 -- unsigned constant created in the main program by the binder.
2796 -- A special exception occurs for Standard, where the string returned
2797 -- is a copy of the library string in gnatvsn.ads.
2799 when Attribute_Body_Version
2803 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2808 -- If not library unit, get to containing library unit
2810 Pent
:= Entity
(Pref
);
2811 while Pent
/= Standard_Standard
2812 and then Scope
(Pent
) /= Standard_Standard
2813 and then not Is_Child_Unit
(Pent
)
2815 Pent
:= Scope
(Pent
);
2818 -- Special case Standard and Standard.ASCII
2820 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2822 Make_String_Literal
(Loc
,
2823 Strval
=> Verbose_Library_Version
));
2828 -- Build required string constant
2830 Get_Name_String
(Get_Unit_Name
(Pent
));
2833 for J
in 1 .. Name_Len
- 2 loop
2834 if Name_Buffer
(J
) = '.' then
2835 Store_String_Chars
("__");
2837 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2841 -- Case of subprogram acting as its own spec, always use body
2843 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2844 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2846 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2848 Store_String_Chars
("B");
2850 -- Case of no body present, always use spec
2852 elsif not Unit_Requires_Body
(Pent
) then
2853 Store_String_Chars
("S");
2855 -- Otherwise use B for Body_Version, S for spec
2857 elsif Id
= Attribute_Body_Version
then
2858 Store_String_Chars
("B");
2860 Store_String_Chars
("S");
2864 Lib
.Version_Referenced
(S
);
2866 -- Insert the object declaration
2868 Insert_Actions
(N
, New_List
(
2869 Make_Object_Declaration
(Loc
,
2870 Defining_Identifier
=> E
,
2871 Object_Definition
=>
2872 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2874 -- Set entity as imported with correct external name
2876 Set_Is_Imported
(E
);
2877 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2879 -- Set entity as internal to ensure proper Sprint output of its
2880 -- implicit importation.
2882 Set_Is_Internal
(E
);
2884 -- And now rewrite original reference
2887 Make_Function_Call
(Loc
,
2889 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2890 Parameter_Associations
=> New_List
(
2891 New_Occurrence_Of
(E
, Loc
))));
2894 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2901 -- Transforms 'Ceiling into a call to the floating-point attribute
2902 -- function Ceiling in Fat_xxx (where xxx is the root type)
2904 when Attribute_Ceiling
=>
2905 Expand_Fpt_Attribute_R
(N
);
2911 -- Transforms 'Callable attribute into a call to the Callable function
2913 when Attribute_Callable
=>
2915 -- We have an object of a task interface class-wide type as a prefix
2916 -- to Callable. Generate:
2917 -- callable (Task_Id (Pref._disp_get_task_id));
2919 if Ada_Version
>= Ada_2005
2920 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2921 and then Is_Interface
(Ptyp
)
2922 and then Is_Task_Interface
(Ptyp
)
2925 Make_Function_Call
(Loc
,
2927 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2928 Parameter_Associations
=> New_List
(
2929 Unchecked_Convert_To
2930 (RTE
(RO_ST_Task_Id
),
2931 Build_Disp_Get_Task_Id_Call
(Pref
)))));
2934 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2937 Analyze_And_Resolve
(N
, Standard_Boolean
);
2943 -- Transforms 'Caller attribute into a call to either the
2944 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2946 when Attribute_Caller
=> Caller
: declare
2947 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2948 Ent
: constant Entity_Id
:= Entity
(Pref
);
2949 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2950 Nest_Depth
: Nat
:= 0;
2957 if Is_Protected_Type
(Conctype
) then
2958 case Corresponding_Runtime_Package
(Conctype
) is
2959 when System_Tasking_Protected_Objects_Entries
=>
2962 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2964 when System_Tasking_Protected_Objects_Single_Entry
=>
2967 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2970 raise Program_Error
;
2974 Unchecked_Convert_To
(Id_Kind
,
2975 Make_Function_Call
(Loc
,
2977 Parameter_Associations
=> New_List
(
2979 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2984 -- Determine the nesting depth of the E'Caller attribute, that
2985 -- is, how many accept statements are nested within the accept
2986 -- statement for E at the point of E'Caller. The runtime uses
2987 -- this depth to find the specified entry call.
2989 for J
in reverse 0 .. Scope_Stack
.Last
loop
2990 S
:= Scope_Stack
.Table
(J
).Entity
;
2992 -- We should not reach the scope of the entry, as it should
2993 -- already have been checked in Sem_Attr that this attribute
2994 -- reference is within a matching accept statement.
2996 pragma Assert
(S
/= Conctype
);
3001 elsif Is_Entry
(S
) then
3002 Nest_Depth
:= Nest_Depth
+ 1;
3007 Unchecked_Convert_To
(Id_Kind
,
3008 Make_Function_Call
(Loc
,
3010 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
3011 Parameter_Associations
=> New_List
(
3012 Make_Integer_Literal
(Loc
,
3013 Intval
=> Nest_Depth
)))));
3016 Analyze_And_Resolve
(N
, Id_Kind
);
3019 --------------------
3020 -- Component_Size --
3021 --------------------
3023 -- Component_Size is handled by the back end
3025 when Attribute_Component_Size
=>
3026 Apply_Universal_Integer_Attribute_Checks
(N
);
3032 -- Transforms 'Compose into a call to the floating-point attribute
3033 -- function Compose in Fat_xxx (where xxx is the root type)
3035 -- Note: we strictly should have special code here to deal with the
3036 -- case of absurdly negative arguments (less than Integer'First)
3037 -- which will return a (signed) zero value, but it hardly seems
3038 -- worth the effort. Absurdly large positive arguments will raise
3039 -- constraint error which is fine.
3041 when Attribute_Compose
=>
3042 Expand_Fpt_Attribute_RI
(N
);
3048 when Attribute_Constrained
=> Constrained
: declare
3049 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
3052 -- Reference to a parameter where the value is passed as an extra
3053 -- actual, corresponding to the extra formal referenced by the
3054 -- Extra_Constrained field of the corresponding formal. If this
3055 -- is an entry in-parameter, it is replaced by a constant renaming
3056 -- for which Extra_Constrained is never created.
3058 if Present
(Formal_Ent
)
3059 and then Ekind
(Formal_Ent
) /= E_Constant
3060 and then Present
(Extra_Constrained
(Formal_Ent
))
3064 (Extra_Constrained
(Formal_Ent
), Loc
));
3066 -- If the prefix is an access to object, the attribute applies to
3067 -- the designated object, so rewrite with an explicit dereference.
3069 elsif Is_Access_Type
(Ptyp
)
3071 (not Is_Entity_Name
(Pref
) or else Is_Object
(Entity
(Pref
)))
3074 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Pref
)));
3076 -- For variables with a Extra_Constrained field, we use the
3077 -- corresponding entity.
3079 elsif Nkind
(Pref
) = N_Identifier
3080 and then Ekind
(Entity
(Pref
)) = E_Variable
3081 and then Present
(Extra_Constrained
(Entity
(Pref
)))
3085 (Extra_Constrained
(Entity
(Pref
)), Loc
));
3087 -- For all other cases, we can tell at compile time
3090 -- For access type, apply access check as needed
3092 if Is_Entity_Name
(Pref
)
3093 and then not Is_Type
(Entity
(Pref
))
3094 and then Is_Access_Type
(Ptyp
)
3096 Apply_Access_Check
(N
);
3102 (Exp_Util
.Attribute_Constrained_Static_Value
(Pref
)), Loc
));
3105 Analyze_And_Resolve
(N
, Standard_Boolean
);
3112 -- Transforms 'Copy_Sign into a call to the floating-point attribute
3113 -- function Copy_Sign in Fat_xxx (where xxx is the root type).
3115 when Attribute_Copy_Sign
=>
3116 Expand_Fpt_Attribute_RR
(N
);
3122 -- Transforms 'Count attribute into a call to the Count function
3124 when Attribute_Count
=> Count
: declare
3126 Conctyp
: Entity_Id
;
3128 Entry_Id
: Entity_Id
;
3133 -- If the prefix is a member of an entry family, retrieve both
3134 -- entry name and index. For a simple entry there is no index.
3136 if Nkind
(Pref
) = N_Indexed_Component
then
3137 Entnam
:= Prefix
(Pref
);
3138 Index
:= First
(Expressions
(Pref
));
3144 Entry_Id
:= Entity
(Entnam
);
3146 -- Find the concurrent type in which this attribute is referenced
3147 -- (there had better be one).
3149 Conctyp
:= Current_Scope
;
3150 while not Is_Concurrent_Type
(Conctyp
) loop
3151 Conctyp
:= Scope
(Conctyp
);
3156 if Is_Protected_Type
(Conctyp
) then
3158 -- No need to transform 'Count into a function call if the current
3159 -- scope has been eliminated. In this case such transformation is
3160 -- also not viable because the enclosing protected object is not
3163 if Is_Eliminated
(Current_Scope
) then
3167 case Corresponding_Runtime_Package
(Conctyp
) is
3168 when System_Tasking_Protected_Objects_Entries
=>
3169 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
3172 Make_Function_Call
(Loc
,
3174 Parameter_Associations
=> New_List
(
3176 (Find_Protection_Object
(Current_Scope
), Loc
),
3177 Entry_Index_Expression
3178 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
3180 when System_Tasking_Protected_Objects_Single_Entry
=>
3182 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
3185 Make_Function_Call
(Loc
,
3187 Parameter_Associations
=> New_List
(
3189 (Find_Protection_Object
(Current_Scope
), Loc
)));
3192 raise Program_Error
;
3199 Make_Function_Call
(Loc
,
3200 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
3201 Parameter_Associations
=> New_List
(
3202 Entry_Index_Expression
(Loc
,
3203 Entry_Id
, Index
, Scope
(Entry_Id
))));
3206 -- The call returns type Natural but the context is universal integer
3207 -- so any integer type is allowed. The attribute was already resolved
3208 -- so its Etype is the required result type. If the base type of the
3209 -- context type is other than Standard.Integer we put in a conversion
3210 -- to the required type. This can be a normal typed conversion since
3211 -- both input and output types of the conversion are integer types
3213 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
3214 Rewrite
(N
, Convert_To
(Typ
, Call
));
3219 Analyze_And_Resolve
(N
, Typ
);
3222 ---------------------
3223 -- Descriptor_Size --
3224 ---------------------
3226 -- Descriptor_Size is handled by the back end
3228 when Attribute_Descriptor_Size
=>
3229 Apply_Universal_Integer_Attribute_Checks
(N
);
3235 -- This processing is shared by Elab_Spec
3237 -- What we do is to insert the following declarations
3240 -- pragma Import (C, enn, "name___elabb/s");
3242 -- and then the Elab_Body/Spec attribute is replaced by a reference
3243 -- to this defining identifier.
3245 when Attribute_Elab_Body
3246 | Attribute_Elab_Spec
3248 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3249 -- back-end knows how to handle these attributes directly.
3251 if CodePeer_Mode
then
3256 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
3260 procedure Make_Elab_String
(Nod
: Node_Id
);
3261 -- Given Nod, an identifier, or a selected component, put the
3262 -- image into the current string literal, with double underline
3263 -- between components.
3265 ----------------------
3266 -- Make_Elab_String --
3267 ----------------------
3269 procedure Make_Elab_String
(Nod
: Node_Id
) is
3271 if Nkind
(Nod
) = N_Selected_Component
then
3272 Make_Elab_String
(Prefix
(Nod
));
3273 Store_String_Char
('_');
3274 Store_String_Char
('_');
3275 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
3278 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
3279 Get_Name_String
(Chars
(Nod
));
3282 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3283 end Make_Elab_String
;
3285 -- Start of processing for Elab_Body/Elab_Spec
3288 -- First we need to prepare the string literal for the name of
3289 -- the elaboration routine to be referenced.
3292 Make_Elab_String
(Pref
);
3293 Store_String_Chars
("___elab");
3294 Lang
:= Make_Identifier
(Loc
, Name_C
);
3296 if Id
= Attribute_Elab_Body
then
3297 Store_String_Char
('b');
3299 Store_String_Char
('s');
3304 Insert_Actions
(N
, New_List
(
3305 Make_Subprogram_Declaration
(Loc
,
3307 Make_Procedure_Specification
(Loc
,
3308 Defining_Unit_Name
=> Ent
)),
3311 Chars
=> Name_Import
,
3312 Pragma_Argument_Associations
=> New_List
(
3313 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3315 Make_Pragma_Argument_Association
(Loc
,
3316 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3318 Make_Pragma_Argument_Association
(Loc
,
3319 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3321 Set_Entity
(N
, Ent
);
3322 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3325 --------------------
3326 -- Elab_Subp_Body --
3327 --------------------
3329 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3330 -- this attribute directly, and if we are not in CodePeer mode it is
3331 -- entirely ignored ???
3333 when Attribute_Elab_Subp_Body
=>
3340 -- Elaborated is always True for preelaborated units, predefined units,
3341 -- pure units and units which have Elaborate_Body pragmas. These units
3342 -- have no elaboration entity.
3344 -- Note: The Elaborated attribute is never passed to the back end
3346 when Attribute_Elaborated
=> Elaborated
: declare
3347 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3350 if Present
(Elab_Id
) then
3353 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3354 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3356 Analyze_And_Resolve
(N
, Typ
);
3358 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3366 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3370 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3373 if Is_Non_Empty_List
(Exprs
) then
3374 Expr
:= First
(Exprs
);
3379 -- If not constant-folded, Enum_Type'Enum_Rep (X) or X'Enum_Rep
3384 -- This is an unchecked conversion from the enumeration type to the
3385 -- target integer type, which is treated by the back end as a normal
3386 -- integer conversion, treating the enumeration type as an integer,
3387 -- which is exactly what we want. Unlike for the Pos attribute, we
3388 -- cannot use a regular conversion since the associated check would
3389 -- involve comparing the converted bounds, i.e. would involve the use
3390 -- of 'Pos instead 'Enum_Rep for these bounds.
3392 -- However the target type is universal integer in most cases, which
3393 -- is a very large type, so in the case of an enumeration type, we
3394 -- first convert to a small signed integer type in order not to lose
3395 -- the size information.
3397 if Is_Enumeration_Type
(Ptyp
) then
3398 Rewrite
(N
, Unchecked_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
3399 Convert_To_And_Rewrite
(Typ
, N
);
3401 -- Deal with integer types (replace by conversion)
3404 Rewrite
(N
, Convert_To
(Typ
, Expr
));
3407 Analyze_And_Resolve
(N
, Typ
);
3414 when Attribute_Enum_Val
=> Enum_Val
: declare
3416 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3419 -- X'Enum_Val (Y) expands to
3421 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3424 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3426 -- Ensure that the expression is not truncated since the "bad" bits
3429 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
3430 Set_No_Truncation
(Expr
);
3434 Make_Raise_Constraint_Error
(Loc
,
3438 Make_Function_Call
(Loc
,
3440 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3441 Parameter_Associations
=> New_List
(
3442 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3443 New_Occurrence_Of
(Standard_False
, Loc
))),
3445 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3446 Reason
=> CE_Range_Check_Failed
));
3449 Analyze_And_Resolve
(N
, Ptyp
);
3456 -- Transforms 'Exponent into a call to the floating-point attribute
3457 -- function Exponent in Fat_xxx (where xxx is the root type)
3459 when Attribute_Exponent
=>
3460 Expand_Fpt_Attribute_R
(N
);
3466 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3468 when Attribute_External_Tag
=>
3470 Make_Function_Call
(Loc
,
3472 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3473 Parameter_Associations
=> New_List
(
3474 Make_Attribute_Reference
(Loc
,
3475 Attribute_Name
=> Name_Tag
,
3476 Prefix
=> Prefix
(N
)))));
3478 Analyze_And_Resolve
(N
, Standard_String
);
3480 -----------------------
3481 -- Finalization_Size --
3482 -----------------------
3484 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3485 function Calculate_Header_Size
return Node_Id
;
3486 -- Generate a runtime call to calculate the size of the hidden header
3487 -- along with any added padding which would precede a heap-allocated
3488 -- object of the prefix type.
3490 ---------------------------
3491 -- Calculate_Header_Size --
3492 ---------------------------
3494 function Calculate_Header_Size
return Node_Id
is
3497 -- Typ (Header_Size_With_Padding (Pref'Alignment))
3501 Make_Function_Call
(Loc
,
3503 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3505 Parameter_Associations
=> New_List
(
3506 Make_Attribute_Reference
(Loc
,
3507 Prefix
=> New_Copy_Tree
(Pref
),
3508 Attribute_Name
=> Name_Alignment
))));
3509 end Calculate_Header_Size
;
3515 -- Start of processing for Finalization_Size
3518 -- An object of a class-wide type first requires a runtime check to
3519 -- determine whether it is actually controlled or not. Depending on
3520 -- the outcome of this check, the Finalization_Size of the object
3521 -- may be zero or some positive value.
3523 -- In this scenario, Pref'Finalization_Size is expanded into
3525 -- Size : Integer := 0;
3527 -- if Needs_Finalization (Pref'Tag) then
3528 -- Size := Integer (Header_Size_With_Padding (Pref'Alignment));
3531 -- and the attribute reference is replaced with a reference to Size.
3533 if Is_Class_Wide_Type
(Ptyp
) then
3534 Size
:= Make_Temporary
(Loc
, 'S');
3536 Insert_Actions
(N
, New_List
(
3539 -- Size : Integer := 0;
3541 Make_Object_Declaration
(Loc
,
3542 Defining_Identifier
=> Size
,
3543 Object_Definition
=>
3544 New_Occurrence_Of
(Standard_Integer
, Loc
),
3545 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3548 -- if Needs_Finalization (Pref'Tag) then
3550 -- Integer (Header_Size_With_Padding (Pref'Alignment));
3553 Make_If_Statement
(Loc
,
3555 Make_Function_Call
(Loc
,
3557 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3559 Parameter_Associations
=> New_List
(
3560 Make_Attribute_Reference
(Loc
,
3561 Prefix
=> New_Copy_Tree
(Pref
),
3562 Attribute_Name
=> Name_Tag
))),
3564 Then_Statements
=> New_List
(
3565 Make_Assignment_Statement
(Loc
,
3566 Name
=> New_Occurrence_Of
(Size
, Loc
),
3569 (Standard_Integer
, Calculate_Header_Size
))))));
3571 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3573 -- The prefix is known to be controlled at compile time. Calculate
3574 -- Finalization_Size by calling function Header_Size_With_Padding.
3576 elsif Needs_Finalization
(Ptyp
) then
3577 Rewrite
(N
, Calculate_Header_Size
);
3579 -- The prefix is not an object with controlled parts, so its
3580 -- Finalization_Size is zero.
3583 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3586 -- Due to cases where the entity type of the attribute is already
3587 -- resolved the rewritten N must get re-resolved to its appropriate
3590 Analyze_And_Resolve
(N
, Typ
);
3591 end Finalization_Size
;
3597 when Attribute_First
3600 -- If the prefix type is a constrained packed array type which
3601 -- already has a Packed_Array_Impl_Type representation defined, then
3602 -- replace this attribute with a direct reference to the attribute of
3603 -- the appropriate index subtype (since otherwise the back end will
3604 -- try to give us the value of 'First for this implementation type).
3605 -- Do not do this if Ptyp depends on a discriminant as its bounds
3606 -- are only available through N.
3608 if Is_Constrained_Packed_Array
(Ptyp
)
3609 and then not Size_Depends_On_Discriminant
(Ptyp
)
3612 Make_Attribute_Reference
(Loc
,
3613 Attribute_Name
=> Attribute_Name
(N
),
3615 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3616 Analyze_And_Resolve
(N
, Typ
);
3618 -- For a constrained array type, if the bound is a reference to an
3619 -- entity which is not a discriminant, just replace with a direct
3620 -- reference. Note that this must be in keeping with what is done
3621 -- for scalar types in order for range checks to be elided in loops.
3623 -- However, avoid doing it if the array type is public because, in
3624 -- this case, we effectively rely on the back end to create public
3625 -- symbols with consistent names across units for the array bounds.
3627 elsif Is_Array_Type
(Ptyp
)
3628 and then Is_Constrained
(Ptyp
)
3629 and then not Is_Public
(Ptyp
)
3635 if Id
= Attribute_First
then
3636 Bnd
:= Type_Low_Bound
(Get_Index_Subtype
(N
));
3638 Bnd
:= Type_High_Bound
(Get_Index_Subtype
(N
));
3641 if Is_Entity_Name
(Bnd
)
3642 and then Ekind
(Entity
(Bnd
)) /= E_Discriminant
3644 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3648 -- For access type, apply access check as needed
3650 elsif Is_Access_Type
(Ptyp
) then
3651 Apply_Access_Check
(N
);
3653 -- For scalar type, if the bound is a reference to an entity, just
3654 -- replace with a direct reference. Note that we can only have a
3655 -- reference to a constant entity at this stage, anything else would
3656 -- have already been rewritten.
3658 elsif Is_Scalar_Type
(Ptyp
) then
3663 if Id
= Attribute_First
then
3664 Bnd
:= Type_Low_Bound
(Ptyp
);
3666 Bnd
:= Type_High_Bound
(Ptyp
);
3669 if Is_Entity_Name
(Bnd
) then
3670 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3679 -- We leave the computation up to the back end, since we don't know what
3680 -- layout will be chosen if no component clause was specified.
3682 when Attribute_First_Bit
=>
3683 Apply_Universal_Integer_Attribute_Checks
(N
);
3685 --------------------------------
3686 -- Fixed_Value, Integer_Value --
3687 --------------------------------
3691 -- fixtype'Fixed_Value (integer-value)
3692 -- inttype'Integer_Value (fixed-value)
3696 -- fixtype (integer-value)
3697 -- inttype (fixed-value)
3701 -- We set Conversion_OK on the conversion because we do not want it
3702 -- to go through the fixed-point conversion circuits.
3704 when Attribute_Fixed_Value
3705 | Attribute_Integer_Value
3707 Rewrite
(N
, OK_Convert_To
(Entity
(Pref
), First
(Exprs
)));
3709 -- Note that it might appear that a properly analyzed unchecked
3710 -- conversion would be just fine here, but that's not the case,
3711 -- since the full range checks performed by the following calls
3714 Apply_Type_Conversion_Checks
(N
);
3716 -- Note that Apply_Type_Conversion_Checks only deals with the
3717 -- overflow checks on conversions involving fixed-point types
3718 -- so we must apply range checks manually on them and expand.
3720 Apply_Scalar_Range_Check
3721 (Expression
(N
), Etype
(N
), Fixed_Int
=> True);
3730 -- Transforms 'Floor into a call to the floating-point attribute
3731 -- function Floor in Fat_xxx (where xxx is the root type)
3733 when Attribute_Floor
=>
3734 Expand_Fpt_Attribute_R
(N
);
3740 -- For the fixed-point type Typ:
3746 -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm])
3748 -- For decimal fixed-point types
3749 -- xx = Decimal{32,64,128}
3750 -- ftyp = Integer_{32,64,128}
3753 -- For the most common ordinary fixed-point types
3754 -- xx = Fixed{32,64,128}
3755 -- ftyp = Integer_{32,64,128}
3756 -- pm = numerator of Typ'Small
3757 -- denominator of Typ'Small
3758 -- min (scale of Typ'Small, 0)
3760 -- For other ordinary fixed-point types
3762 -- ftyp = Long_Float
3765 -- Note that we know that the type is a nonstatic subtype, or Fore would
3766 -- have been computed statically in Eval_Attribute.
3768 when Attribute_Fore
=>
3775 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3776 if Esize
(Ptyp
) <= 32 then
3777 Fid
:= RE_Fore_Decimal32
;
3778 Ftyp
:= RTE
(RE_Integer_32
);
3779 elsif Esize
(Ptyp
) <= 64 then
3780 Fid
:= RE_Fore_Decimal64
;
3781 Ftyp
:= RTE
(RE_Integer_64
);
3783 Fid
:= RE_Fore_Decimal128
;
3784 Ftyp
:= RTE
(RE_Integer_128
);
3789 Num
: constant Uint
:= Norm_Num
(Small_Value
(Ptyp
));
3790 Den
: constant Uint
:= Norm_Den
(Small_Value
(Ptyp
));
3791 Max
: constant Uint
:= UI_Max
(Num
, Den
);
3792 Min
: constant Uint
:= UI_Min
(Num
, Den
);
3793 Siz
: constant Uint
:= Esize
(Ptyp
);
3797 and then Max
<= Uint_2
** 31
3798 and then (Min
= Uint_1
3800 or else Num
< Uint_10
** 8)
3802 Fid
:= RE_Fore_Fixed32
;
3803 Ftyp
:= RTE
(RE_Integer_32
);
3805 and then Max
<= Uint_2
** 63
3806 and then (Min
= Uint_1
3808 or else Num
< Uint_10
** 17)
3810 Fid
:= RE_Fore_Fixed64
;
3811 Ftyp
:= RTE
(RE_Integer_64
);
3812 elsif System_Max_Integer_Size
= 128
3813 and then Max
<= Uint_2
** 127
3814 and then (Min
= Uint_1
3816 or else Num
< Uint_10
** 37)
3818 Fid
:= RE_Fore_Fixed128
;
3819 Ftyp
:= RTE
(RE_Integer_128
);
3821 Fid
:= RE_Fore_Fixed
;
3822 Ftyp
:= Standard_Long_Float
;
3827 Arg_List
:= New_List
(
3829 Make_Attribute_Reference
(Loc
,
3830 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3831 Attribute_Name
=> Name_First
)));
3833 Append_To
(Arg_List
,
3835 Make_Attribute_Reference
(Loc
,
3836 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3837 Attribute_Name
=> Name_Last
)));
3839 -- For decimal, append Scale and also set to do literal conversion
3841 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3842 Set_Conversion_OK
(First
(Arg_List
));
3843 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3845 Append_To
(Arg_List
,
3846 Make_Integer_Literal
(Loc
, Scale_Value
(Ptyp
)));
3848 -- For ordinary fixed-point types, append Num, Den and Scale
3849 -- parameters and also set to do literal conversion
3851 elsif Fid
/= RE_Fore_Fixed
then
3852 Set_Conversion_OK
(First
(Arg_List
));
3853 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3855 Append_To
(Arg_List
,
3856 Make_Integer_Literal
(Loc
, -Norm_Num
(Small_Value
(Ptyp
))));
3858 Append_To
(Arg_List
,
3859 Make_Integer_Literal
(Loc
, -Norm_Den
(Small_Value
(Ptyp
))));
3862 Val
: Ureal
:= Small_Value
(Ptyp
);
3866 while Val
>= Ureal_10
loop
3867 Val
:= Val
/ Ureal_10
;
3871 Append_To
(Arg_List
,
3872 Make_Integer_Literal
(Loc
, UI_From_Int
(Scale
)));
3878 Make_Function_Call
(Loc
,
3880 New_Occurrence_Of
(RTE
(Fid
), Loc
),
3881 Parameter_Associations
=> Arg_List
)));
3883 Analyze_And_Resolve
(N
, Typ
);
3890 -- Transforms 'Fraction into a call to the floating-point attribute
3891 -- function Fraction in Fat_xxx (where xxx is the root type)
3893 when Attribute_Fraction
=>
3894 Expand_Fpt_Attribute_R
(N
);
3900 when Attribute_From_Any
=> From_Any
: declare
3901 Decls
: constant List_Id
:= New_List
;
3905 Build_From_Any_Call
(Ptyp
,
3906 Relocate_Node
(First
(Exprs
)),
3908 Insert_Actions
(N
, Decls
);
3909 Analyze_And_Resolve
(N
, Ptyp
);
3912 ----------------------
3913 -- Has_Same_Storage --
3914 ----------------------
3916 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3917 Loc
: constant Source_Ptr
:= Sloc
(N
);
3919 X
: constant Node_Id
:= Prefix
(N
);
3920 Y
: constant Node_Id
:= First
(Expressions
(N
));
3925 -- Rhe expressions for their addresses
3929 -- Rhe expressions for their sizes
3932 -- The attribute is expanded as:
3934 -- (X'address = Y'address)
3935 -- and then (X'Size = Y'Size)
3936 -- and then (X'Size /= 0) (AI12-0077)
3938 -- If both arguments have the same Etype the second conjunct can be
3942 Make_Attribute_Reference
(Loc
,
3943 Attribute_Name
=> Name_Address
,
3944 Prefix
=> New_Copy_Tree
(X
));
3947 Make_Attribute_Reference
(Loc
,
3948 Attribute_Name
=> Name_Address
,
3949 Prefix
=> New_Copy_Tree
(Y
));
3952 Make_Attribute_Reference
(Loc
,
3953 Attribute_Name
=> Name_Size
,
3954 Prefix
=> New_Copy_Tree
(X
));
3956 if Etype
(X
) = Etype
(Y
) then
3961 Left_Opnd
=> X_Addr
,
3962 Right_Opnd
=> Y_Addr
),
3965 Left_Opnd
=> X_Size
,
3966 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))));
3969 Make_Attribute_Reference
(Loc
,
3970 Attribute_Name
=> Name_Size
,
3971 Prefix
=> New_Copy_Tree
(Y
));
3977 Left_Opnd
=> X_Addr
,
3978 Right_Opnd
=> Y_Addr
),
3983 Left_Opnd
=> X_Size
,
3984 Right_Opnd
=> Y_Size
),
3987 Left_Opnd
=> New_Copy_Tree
(X_Size
),
3988 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)))));
3991 Analyze_And_Resolve
(N
, Standard_Boolean
);
3992 end Has_Same_Storage
;
3998 -- For an exception returns a reference to the exception data:
3999 -- Exception_Id!(Prefix'Reference)
4001 -- For a task it returns a reference to the _task_id component of
4002 -- corresponding record:
4004 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
4006 -- in Ada.Task_Identification
4008 when Attribute_Identity
=> Identity
: declare
4009 Id_Kind
: Entity_Id
;
4012 if Ptyp
= Standard_Exception_Type
then
4013 Id_Kind
:= RTE
(RE_Exception_Id
);
4015 if Present
(Renamed_Entity
(Entity
(Pref
))) then
4016 Set_Entity
(Pref
, Renamed_Entity
(Entity
(Pref
)));
4020 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
4022 Id_Kind
:= RTE
(RO_AT_Task_Id
);
4024 -- If the prefix is a task interface, the Task_Id is obtained
4025 -- dynamically through a dispatching call, as for other task
4026 -- attributes applied to interfaces.
4028 if Ada_Version
>= Ada_2005
4029 and then Ekind
(Ptyp
) = E_Class_Wide_Type
4030 and then Is_Interface
(Ptyp
)
4031 and then Is_Task_Interface
(Ptyp
)
4034 Unchecked_Convert_To
4035 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
4039 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
4043 Analyze_And_Resolve
(N
, Id_Kind
);
4050 when Attribute_Image
=>
4052 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
4053 -- back-end knows how to handle this attribute directly.
4055 if CodePeer_Mode
then
4059 Exp_Imgv
.Expand_Image_Attribute
(N
);
4065 -- X'Img is expanded to typ'Image (X), where typ is the type of X
4067 when Attribute_Img
=>
4068 Exp_Imgv
.Expand_Image_Attribute
(N
);
4074 -- Transforms 'Index attribute into a reference to the second formal of
4075 -- the wrapper built for an entry family that has contract cases (see
4076 -- Exp_Ch9.Build_Contract_Wrapper).
4078 when Attribute_Index
=> Index
: declare
4079 Entry_Id
: constant Entity_Id
:= Entity
(Pref
);
4080 Entry_Idx
: constant Entity_Id
:=
4082 (First_Entity
(Contract_Wrapper
(Entry_Id
)));
4084 Rewrite
(N
, New_Occurrence_Of
(Entry_Idx
, Loc
));
4085 Analyze_And_Resolve
(N
, Typ
);
4092 -- For execution, we could either implement an approximation of this
4093 -- aspect, or use Valid_Scalars as a first approximation. For now we do
4096 when Attribute_Initialized
=>
4098 -- Do not expand 'Initialized in CodePeer mode, it will be handled
4099 -- by the back-end directly.
4101 if CodePeer_Mode
then
4107 Make_Attribute_Reference
4110 Attribute_Name
=> Name_Valid_Scalars
,
4111 Expressions
=> Exprs
));
4113 Analyze_And_Resolve
(N
);
4119 when Attribute_Input
=> Input
: declare
4120 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4121 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
4122 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4123 Strm
: constant Node_Id
:= First
(Exprs
);
4131 Cntrl
: Node_Id
:= Empty
;
4132 -- Value for controlling argument in call. Always Empty except in
4133 -- the dispatching (class-wide type) case, where it is a reference
4134 -- to the dummy object initialized to the right internal tag.
4136 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
4137 -- The expansion of the attribute reference may generate a call to
4138 -- a user-defined stream subprogram that is frozen by the call. This
4139 -- can lead to access-before-elaboration problem if the reference
4140 -- appears in an object declaration and the subprogram body has not
4141 -- been seen. The freezing of the subprogram requires special code
4142 -- because it appears in an expanded context where expressions do
4143 -- not freeze their constituents.
4145 ------------------------------
4146 -- Freeze_Stream_Subprogram --
4147 ------------------------------
4149 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
4150 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
4154 -- If this is user-defined subprogram, the corresponding
4155 -- stream function appears as a renaming-as-body, and the
4156 -- user subprogram must be retrieved by tree traversal.
4159 and then Nkind
(Decl
) = N_Subprogram_Declaration
4160 and then Present
(Corresponding_Body
(Decl
))
4162 Bod
:= Corresponding_Body
(Decl
);
4164 if Nkind
(Unit_Declaration_Node
(Bod
)) =
4165 N_Subprogram_Renaming_Declaration
4167 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
4170 end Freeze_Stream_Subprogram
;
4172 -- Start of processing for Input
4175 -- If no underlying type, we have an error that will be diagnosed
4176 -- elsewhere, so here we just completely ignore the expansion.
4182 -- Stream operations can appear in user code even if the restriction
4183 -- No_Streams is active (for example, when instantiating a predefined
4184 -- container). In that case rewrite the attribute as a Raise to
4185 -- prevent any run-time use.
4187 if Restriction_Active
(No_Streams
) then
4189 Make_Raise_Program_Error
(Sloc
(N
),
4190 Reason
=> PE_Stream_Operation_Not_Allowed
));
4191 Set_Etype
(N
, B_Type
);
4195 -- If there is a TSS for Input, just call it
4197 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
4199 if Present
(Fname
) then
4203 -- If there is a Stream_Convert pragma, use it, we rewrite
4205 -- sourcetyp'Input (stream)
4209 -- sourcetyp (streamread (strmtyp'Input (stream)));
4211 -- where streamread is the given Read function that converts an
4212 -- argument of type strmtyp to type sourcetyp or a type from which
4213 -- it is derived (extra conversion required for the derived case).
4215 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4217 if Present
(Prag
) then
4218 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4219 Rfunc
:= Entity
(Expression
(Arg2
));
4223 Make_Function_Call
(Loc
,
4224 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4225 Parameter_Associations
=> New_List
(
4226 Make_Attribute_Reference
(Loc
,
4229 (Etype
(First_Formal
(Rfunc
)), Loc
),
4230 Attribute_Name
=> Name_Input
,
4231 Expressions
=> Exprs
)))));
4233 Analyze_And_Resolve
(N
, B_Type
);
4238 elsif Default_Streaming_Unavailable
(U_Type
) then
4239 -- Do the same thing here as is done above in the
4240 -- case where a No_Streams restriction is active.
4243 Make_Raise_Program_Error
(Sloc
(N
),
4244 Reason
=> PE_Stream_Operation_Not_Allowed
));
4245 Set_Etype
(N
, B_Type
);
4250 elsif Is_Elementary_Type
(U_Type
) then
4252 -- A special case arises if we have a defined _Read routine,
4253 -- since in this case we are required to call this routine.
4255 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Read
)) then
4256 Build_Record_Or_Elementary_Input_Function
4257 (Loc
, P_Type
, Decl
, Fname
);
4258 Insert_Action
(N
, Decl
);
4260 -- For normal cases, we call the I_xxx routine directly
4263 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
4264 Analyze_And_Resolve
(N
, P_Type
);
4270 elsif Is_Array_Type
(U_Type
) then
4271 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
4272 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
4274 -- Dispatching case with class-wide type
4276 elsif Is_Class_Wide_Type
(P_Type
) then
4278 -- No need to do anything else compiling under restriction
4279 -- No_Dispatching_Calls. During the semantic analysis we
4280 -- already notified such violation.
4282 if Restriction_Active
(No_Dispatching_Calls
) then
4287 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
4289 Expr
: Node_Id
; -- call to Descendant_Tag
4290 Get_Tag
: Node_Id
; -- expression to read the 'Tag
4293 -- Read the internal tag (RM 13.13.2(34)) and use it to
4294 -- initialize a dummy tag value. We used to unconditionally
4297 -- Descendant_Tag (String'Input (Strm), P_Type);
4299 -- which turns into a call to String_Input_Blk_IO. However,
4300 -- if the input is malformed, that could try to read an
4301 -- enormous String, causing chaos. So instead we call
4302 -- String_Input_Tag, which does the same thing as
4303 -- String_Input_Blk_IO, except that if the String is
4304 -- absurdly long, it raises an exception.
4306 -- However, if the No_Stream_Optimizations restriction
4307 -- is active, we disable this unnecessary attempt at
4308 -- robustness; we really need to read the string
4309 -- character-by-character.
4311 -- This value is used only to provide a controlling
4312 -- argument for the eventual _Input call. Descendant_Tag is
4313 -- called rather than Internal_Tag to ensure that we have a
4314 -- tag for a type that is descended from the prefix type and
4315 -- declared at the same accessibility level (the exception
4316 -- Tag_Error will be raised otherwise). The level check is
4317 -- required for Ada 2005 because tagged types can be
4318 -- extended in nested scopes (AI-344).
4320 -- Note: we used to generate an explicit declaration of a
4321 -- constant Ada.Tags.Tag object, and use an occurrence of
4322 -- this constant in Cntrl, but this caused a secondary stack
4325 if Restriction_Active
(No_Stream_Optimizations
) then
4327 Make_Attribute_Reference
(Loc
,
4329 New_Occurrence_Of
(Standard_String
, Loc
),
4330 Attribute_Name
=> Name_Input
,
4331 Expressions
=> New_List
(
4332 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4335 Make_Function_Call
(Loc
,
4338 (RTE
(RE_String_Input_Tag
), Loc
),
4339 Parameter_Associations
=> New_List
(
4340 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4344 Make_Function_Call
(Loc
,
4346 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
4347 Parameter_Associations
=> New_List
(
4349 Make_Attribute_Reference
(Loc
,
4350 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
4351 Attribute_Name
=> Name_Tag
)));
4353 Set_Etype
(Expr
, RTE
(RE_Tag
));
4355 -- Now we need to get the entity for the call, and construct
4356 -- a function call node, where we preset a reference to Dnn
4357 -- as the controlling argument (doing an unchecked convert
4358 -- to the class-wide tagged type to make it look like a real
4361 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
4362 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
4363 Set_Etype
(Cntrl
, P_Type
);
4364 Set_Parent
(Cntrl
, N
);
4367 -- For tagged types, use the primitive Input function
4369 elsif Is_Tagged_Type
(U_Type
) then
4370 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
4372 -- All other record type cases, including protected records. The
4373 -- latter only arise for expander generated code for handling
4374 -- shared passive partition access.
4378 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4380 -- Ada 2005 (AI-216): Program_Error is raised executing default
4381 -- implementation of the Input attribute of an unchecked union
4382 -- type if the type lacks default discriminant values.
4384 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4386 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
4389 Make_Raise_Program_Error
(Loc
,
4390 Reason
=> PE_Unchecked_Union_Restriction
));
4391 Set_Etype
(N
, B_Type
);
4395 -- Build the type's Input function, passing the subtype rather
4396 -- than its base type, because checks are needed in the case of
4397 -- constrained discriminants (see Ada 2012 AI05-0192).
4399 Build_Record_Or_Elementary_Input_Function
4400 (Loc
, U_Type
, Decl
, Fname
);
4401 Insert_Action
(N
, Decl
);
4403 if Nkind
(Parent
(N
)) = N_Object_Declaration
4404 and then Is_Record_Type
(U_Type
)
4406 -- The stream function may contain calls to user-defined
4407 -- Read procedures for individual components.
4414 Comp
:= First_Component
(U_Type
);
4415 while Present
(Comp
) loop
4417 Find_Stream_Subprogram
4418 (Etype
(Comp
), TSS_Stream_Read
);
4420 if Present
(Func
) then
4421 Freeze_Stream_Subprogram
(Func
);
4424 Next_Component
(Comp
);
4431 -- If we fall through, Fname is the function to be called. The result
4432 -- is obtained by calling the appropriate function, then converting
4433 -- the result. The conversion does a subtype check.
4436 Make_Function_Call
(Loc
,
4437 Name
=> New_Occurrence_Of
(Fname
, Loc
),
4438 Parameter_Associations
=> New_List
(
4439 Relocate_Node
(Strm
)));
4441 Set_Controlling_Argument
(Call
, Cntrl
);
4442 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
4443 Analyze_And_Resolve
(N
, P_Type
);
4445 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4446 Freeze_Stream_Subprogram
(Fname
);
4454 when Attribute_Invalid_Value
=>
4455 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
4457 -- The value produced may be a conversion of a literal, which must be
4458 -- resolved to establish its proper type.
4460 Analyze_And_Resolve
(N
);
4466 -- We leave the computation up to the back end, since we don't know what
4467 -- layout will be chosen if no component clause was specified.
4469 when Attribute_Last_Bit
=>
4470 Apply_Universal_Integer_Attribute_Checks
(N
);
4476 -- Transforms 'Leading_Part into a call to the floating-point attribute
4477 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4479 -- Note: strictly, we should generate special case code to deal with
4480 -- absurdly large positive arguments (greater than Integer'Last), which
4481 -- result in returning the first argument unchanged, but it hardly seems
4482 -- worth the effort. We raise constraint error for absurdly negative
4483 -- arguments which is fine.
4485 when Attribute_Leading_Part
=>
4486 Expand_Fpt_Attribute_RI
(N
);
4492 when Attribute_Length
=> Length
: declare
4497 -- Processing for packed array types
4499 if Is_Packed_Array
(Ptyp
) then
4500 Ityp
:= Get_Index_Subtype
(N
);
4502 -- If the index type, Ityp, is an enumeration type with holes,
4503 -- then we calculate X'Length explicitly using
4506 -- (0, Ityp'Pos (X'Last (N)) -
4507 -- Ityp'Pos (X'First (N)) + 1);
4509 -- Since the bounds in the template are the representation values
4510 -- and the back end would get the wrong value.
4512 if Is_Enumeration_Type
(Ityp
)
4513 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4518 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4522 Make_Attribute_Reference
(Loc
,
4523 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4524 Attribute_Name
=> Name_Max
,
4525 Expressions
=> New_List
4526 (Make_Integer_Literal
(Loc
, 0),
4530 Make_Op_Subtract
(Loc
,
4532 Make_Attribute_Reference
(Loc
,
4533 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4534 Attribute_Name
=> Name_Pos
,
4536 Expressions
=> New_List
(
4537 Make_Attribute_Reference
(Loc
,
4538 Prefix
=> Duplicate_Subexpr
(Pref
),
4539 Attribute_Name
=> Name_Last
,
4540 Expressions
=> New_List
(
4541 Make_Integer_Literal
(Loc
, Xnum
))))),
4544 Make_Attribute_Reference
(Loc
,
4545 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4546 Attribute_Name
=> Name_Pos
,
4548 Expressions
=> New_List
(
4549 Make_Attribute_Reference
(Loc
,
4551 Duplicate_Subexpr_No_Checks
(Pref
),
4552 Attribute_Name
=> Name_First
,
4553 Expressions
=> New_List
(
4554 Make_Integer_Literal
(Loc
, Xnum
)))))),
4556 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4558 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4561 -- If the prefix type is a constrained packed array type which
4562 -- already has a Packed_Array_Impl_Type representation defined,
4563 -- then replace this attribute with a reference to 'Range_Length
4564 -- of the appropriate index subtype (since otherwise the
4565 -- back end will try to give us the value of 'Length for
4566 -- this implementation type).s
4568 elsif Is_Constrained
(Ptyp
) then
4570 Make_Attribute_Reference
(Loc
,
4571 Attribute_Name
=> Name_Range_Length
,
4572 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4573 Analyze_And_Resolve
(N
, Typ
);
4578 elsif Is_Access_Type
(Ptyp
) then
4579 Apply_Access_Check
(N
);
4581 -- If the designated type is a packed array type, then we convert
4582 -- the reference to:
4585 -- xtyp'Pos (Pref'Last (Expr)) -
4586 -- xtyp'Pos (Pref'First (Expr)));
4588 -- This is a bit complex, but it is the easiest thing to do that
4589 -- works in all cases including enum types with holes xtyp here
4590 -- is the appropriate index type.
4593 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4597 if Is_Packed_Array
(Dtyp
) then
4598 Xtyp
:= Get_Index_Subtype
(N
);
4601 Make_Attribute_Reference
(Loc
,
4602 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4603 Attribute_Name
=> Name_Max
,
4604 Expressions
=> New_List
(
4605 Make_Integer_Literal
(Loc
, 0),
4608 Make_Integer_Literal
(Loc
, 1),
4609 Make_Op_Subtract
(Loc
,
4611 Make_Attribute_Reference
(Loc
,
4612 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4613 Attribute_Name
=> Name_Pos
,
4614 Expressions
=> New_List
(
4615 Make_Attribute_Reference
(Loc
,
4616 Prefix
=> Duplicate_Subexpr
(Pref
),
4617 Attribute_Name
=> Name_Last
,
4619 New_Copy_List
(Exprs
)))),
4622 Make_Attribute_Reference
(Loc
,
4623 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4624 Attribute_Name
=> Name_Pos
,
4625 Expressions
=> New_List
(
4626 Make_Attribute_Reference
(Loc
,
4628 Duplicate_Subexpr_No_Checks
(Pref
),
4629 Attribute_Name
=> Name_First
,
4631 New_Copy_List
(Exprs
)))))))));
4633 Analyze_And_Resolve
(N
, Typ
);
4637 -- Otherwise leave it to the back end
4640 Apply_Universal_Integer_Attribute_Checks
(N
);
4644 -- Attribute Loop_Entry is replaced with a reference to a constant value
4645 -- which captures the prefix at the entry point of the related loop. The
4646 -- loop itself may be transformed into a conditional block.
4648 when Attribute_Loop_Entry
=>
4649 Expand_Loop_Entry_Attribute
(N
);
4655 -- Transforms 'Machine into a call to the floating-point attribute
4656 -- function Machine in Fat_xxx (where xxx is the root type).
4657 -- Expansion is avoided for cases the back end can handle directly.
4659 when Attribute_Machine
=>
4660 if not Is_Inline_Floating_Point_Attribute
(N
) then
4661 Expand_Fpt_Attribute_R
(N
);
4664 ----------------------
4665 -- Machine_Rounding --
4666 ----------------------
4668 -- Transforms 'Machine_Rounding into a call to the floating-point
4669 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4670 -- type). Expansion is avoided for cases the back end can handle
4673 when Attribute_Machine_Rounding
=>
4674 if not Is_Inline_Floating_Point_Attribute
(N
) then
4675 Expand_Fpt_Attribute_R
(N
);
4682 -- Machine_Size is equivalent to Object_Size, so transform it into
4683 -- Object_Size and that way the back end never sees Machine_Size.
4685 when Attribute_Machine_Size
=>
4687 Make_Attribute_Reference
(Loc
,
4688 Prefix
=> Prefix
(N
),
4689 Attribute_Name
=> Name_Object_Size
));
4691 Analyze_And_Resolve
(N
, Typ
);
4697 -- The only case that can get this far is the dynamic case of the old
4698 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4705 -- ityp (System.Mantissa.Mantissa_Value
4706 -- (Integer'Integer_Value (typ'First),
4707 -- Integer'Integer_Value (typ'Last)));
4709 when Attribute_Mantissa
=>
4712 Make_Function_Call
(Loc
,
4714 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4716 Parameter_Associations
=> New_List
(
4717 Make_Attribute_Reference
(Loc
,
4718 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4719 Attribute_Name
=> Name_Integer_Value
,
4720 Expressions
=> New_List
(
4721 Make_Attribute_Reference
(Loc
,
4722 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4723 Attribute_Name
=> Name_First
))),
4725 Make_Attribute_Reference
(Loc
,
4726 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4727 Attribute_Name
=> Name_Integer_Value
,
4728 Expressions
=> New_List
(
4729 Make_Attribute_Reference
(Loc
,
4730 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4731 Attribute_Name
=> Name_Last
)))))));
4733 Analyze_And_Resolve
(N
, Typ
);
4739 when Attribute_Max
=>
4740 Expand_Min_Max_Attribute
(N
);
4742 ----------------------------------
4743 -- Max_Size_In_Storage_Elements --
4744 ----------------------------------
4746 when Attribute_Max_Size_In_Storage_Elements
=> declare
4747 Typ
: constant Entity_Id
:= Etype
(N
);
4750 -- If the prefix is X'Class, we transform it into a direct reference
4751 -- to the class-wide type, because the back end must not see a 'Class
4752 -- reference. See also 'Size.
4754 if Is_Entity_Name
(Pref
)
4755 and then Is_Class_Wide_Type
(Entity
(Pref
))
4757 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4761 -- Heap-allocated controlled objects contain two extra pointers which
4762 -- are not part of the actual type. Transform the attribute reference
4763 -- into a runtime expression to add the size of the hidden header.
4765 if Needs_Finalization
(Ptyp
) and then not Header_Size_Added
(N
) then
4766 Set_Header_Size_Added
(N
);
4769 -- P'Max_Size_In_Storage_Elements +
4770 -- Typ (Header_Size_With_Padding (Ptyp'Alignment))
4774 Left_Opnd
=> Relocate_Node
(N
),
4777 Make_Function_Call
(Loc
,
4780 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4782 Parameter_Associations
=> New_List
(
4783 Make_Attribute_Reference
(Loc
,
4785 New_Occurrence_Of
(Ptyp
, Loc
),
4786 Attribute_Name
=> Name_Alignment
))))));
4788 Analyze_And_Resolve
(N
, Typ
);
4792 -- In the other cases apply the required checks
4794 Apply_Universal_Integer_Attribute_Checks
(N
);
4797 --------------------
4798 -- Mechanism_Code --
4799 --------------------
4801 when Attribute_Mechanism_Code
=>
4803 -- We must replace the prefix in the renamed case
4805 if Is_Entity_Name
(Pref
)
4806 and then Present
(Alias
(Entity
(Pref
)))
4808 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4815 when Attribute_Min
=>
4816 Expand_Min_Max_Attribute
(N
);
4822 when Attribute_Mod
=> Mod_Case
: declare
4823 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4824 Hi
: constant Node_Id
:= Type_High_Bound
(Base_Type
(Etype
(Arg
)));
4825 Modv
: constant Uint
:= Modulus
(Btyp
);
4829 -- This is not so simple. The issue is what type to use for the
4830 -- computation of the modular value. In addition we need to use
4831 -- the base type as above to retrieve a static bound for the
4832 -- comparisons that follow.
4834 -- The easy case is when the modulus value is within the bounds
4835 -- of the signed integer type of the argument. In this case we can
4836 -- just do the computation in that signed integer type, and then
4837 -- do an ordinary conversion to the target type.
4839 if Modv
<= Expr_Value
(Hi
) then
4844 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4846 -- Here we know that the modulus is larger than type'Last of the
4847 -- integer type. There are two cases to consider:
4849 -- a) The integer value is non-negative. In this case, it is
4850 -- returned as the result (since it is less than the modulus).
4852 -- b) The integer value is negative. In this case, we know that the
4853 -- result is modulus + value, where the value might be as small as
4854 -- -modulus. The trouble is what type do we use to do the subtract.
4855 -- No type will do, since modulus can be as big as 2**128, and no
4856 -- integer type accommodates this value. Let's do bit of algebra
4859 -- = modulus - (-value)
4860 -- = (modulus - 1) - (-value - 1)
4862 -- Now modulus - 1 is certainly in range of the modular type.
4863 -- -value is in the range 1 .. modulus, so -value -1 is in the
4864 -- range 0 .. modulus-1 which is in range of the modular type.
4865 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4866 -- which we can compute using the integer base type.
4868 -- Once this is done we analyze the if expression without range
4869 -- checks, because we know everything is in range, and we want
4870 -- to prevent spurious warnings on either branch.
4874 Make_If_Expression
(Loc
,
4875 Expressions
=> New_List
(
4877 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4878 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4881 Duplicate_Subexpr_No_Checks
(Arg
)),
4883 Make_Op_Subtract
(Loc
,
4885 Make_Integer_Literal
(Loc
,
4886 Intval
=> Modv
- 1),
4892 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4894 Make_Integer_Literal
(Loc
,
4895 Intval
=> 1))))))));
4899 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4906 -- Transforms 'Model into a call to the floating-point attribute
4907 -- function Model in Fat_xxx (where xxx is the root type).
4908 -- Expansion is avoided for cases the back end can handle directly.
4910 when Attribute_Model
=>
4911 if not Is_Inline_Floating_Point_Attribute
(N
) then
4912 Expand_Fpt_Attribute_R
(N
);
4919 -- The processing for Object_Size shares the processing for Size
4925 when Attribute_Old
=> Old
: declare
4926 CW_Temp
: Entity_Id
;
4933 use Old_Attr_Util
.Conditional_Evaluation
;
4934 use Old_Attr_Util
.Indirect_Temps
;
4936 -- Generating C code we don't need to expand this attribute when
4937 -- we are analyzing the internally built nested _Wrapped_Statements
4938 -- procedure since it will be expanded inline (and later it will
4939 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4940 -- performed in such case then the compiler generates unreferenced
4941 -- extra temporaries.
4943 if Modify_Tree_For_C
4944 and then Chars
(Current_Scope
) = Name_uWrapped_Statements
4949 -- Climb the parent chain looking for subprogram _Wrapped_Statements
4952 while Present
(Subp
) loop
4953 exit when Nkind
(Subp
) = N_Subprogram_Body
4954 and then Chars
(Defining_Entity
(Subp
))
4955 = Name_uWrapped_Statements
;
4957 -- If assertions are disabled, no need to create the declaration
4958 -- that preserves the value. The postcondition pragma in which
4959 -- 'Old appears will be checked or disabled according to the
4960 -- current policy in effect.
4962 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4966 Subp
:= Parent
(Subp
);
4970 -- 'Old can only appear in the case where local contract-related
4971 -- wrapper has been generated with the purpose of wrapping the
4972 -- original declarations and statements.
4974 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4976 -- Set the entity kind now in order to mark the temporary as a
4977 -- handler of attribute 'Old's prefix.
4979 Mutate_Ekind
(Temp
, E_Constant
);
4980 Set_Stores_Attribute_Old_Prefix
(Temp
);
4982 -- Push the scope of the related subprogram where _Postcondition
4983 -- resides as this ensures that the object will be analyzed in the
4986 if Present
(Subp
) then
4987 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4989 -- No need to push the scope when generating C code since the
4990 -- _Postcondition procedure has been inlined.
4996 -- Locate the insertion place of the internal temporary that saves
4999 if Present
(Subp
) then
5002 -- General case where the postcondtion checks occur after the call
5003 -- to _Wrapped_Statements.
5007 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
5008 Ins_Nod
:= Parent
(Ins_Nod
);
5011 if Present
(Corresponding_Spec
(Ins_Nod
))
5013 (Wrapped_Statements
(Corresponding_Spec
(Ins_Nod
)))
5015 Ins_Nod
:= Last
(Declarations
(Ins_Nod
));
5017 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
5021 if Eligible_For_Conditional_Evaluation
(N
) then
5023 Eval_Stmts
: constant List_Id
:= New_List
;
5025 procedure Append_For_Indirect_Temp
5026 (N
: Node_Id
; Is_Eval_Stmt
: Boolean);
5027 -- Append either a declaration (which is to be elaborated
5028 -- unconditionally) or an evaluation statement (which is
5029 -- to be executed conditionally).
5031 ------------------------------
5032 -- Append_For_Indirect_Temp --
5033 ------------------------------
5035 procedure Append_For_Indirect_Temp
5036 (N
: Node_Id
; Is_Eval_Stmt
: Boolean)
5039 if Is_Eval_Stmt
then
5040 Append_To
(Eval_Stmts
, N
);
5042 Insert_Before_And_Analyze
(Ins_Nod
, N
);
5044 end Append_For_Indirect_Temp
;
5046 procedure Declare_Indirect_Temporary
is new
5047 Declare_Indirect_Temp
5048 (Append_Item
=> Append_For_Indirect_Temp
);
5050 Declare_Indirect_Temporary
5051 (Attr_Prefix
=> Pref
, Indirect_Temp
=> Temp
);
5053 Insert_After_And_Analyze
(
5057 Condition
=> Conditional_Evaluation_Condition
(N
),
5058 Then_Statements
=> Eval_Stmts
));
5060 Rewrite
(N
, Indirect_Temp_Value
5062 Typ
=> Etype
(Pref
),
5065 if Present
(Subp
) then
5071 -- Preserve the tag of the prefix by offering a specific view of the
5072 -- class-wide version of the prefix.
5074 elsif Is_Tagged_Type
(Typ
) then
5077 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
5079 CW_Temp
:= Make_Temporary
(Loc
, 'T');
5080 CW_Typ
:= Class_Wide_Type
(Typ
);
5083 Make_Object_Declaration
(Loc
,
5084 Defining_Identifier
=> CW_Temp
,
5085 Constant_Present
=> True,
5086 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
5088 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
5090 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5093 -- Temp : Typ renames Typ (CW_Temp);
5095 Insert_Before_And_Analyze
(Ins_Nod
,
5096 Make_Object_Renaming_Declaration
(Loc
,
5097 Defining_Identifier
=> Temp
,
5098 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5100 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
5102 Set_Stores_Attribute_Old_Prefix
(CW_Temp
);
5108 -- Temp : constant Typ := Pref;
5111 Make_Object_Declaration
(Loc
,
5112 Defining_Identifier
=> Temp
,
5113 Constant_Present
=> True,
5114 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5115 Expression
=> Relocate_Node
(Pref
));
5117 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5121 if Present
(Subp
) then
5125 -- Ensure that the prefix of attribute 'Old is valid. The check must
5126 -- be inserted after the expansion of the attribute has taken place
5127 -- to reflect the new placement of the prefix.
5129 if Validity_Checks_On
and then Validity_Check_Operands
then
5131 -- Object declaration that captures the attribute prefix might
5132 -- be rewritten into object renaming declaration.
5134 if Nkind
(Decl
) = N_Object_Declaration
then
5135 Ensure_Valid
(Expression
(Decl
));
5137 pragma Assert
(Nkind
(Decl
) = N_Object_Renaming_Declaration
5138 and then Is_Rewrite_Substitution
(Decl
));
5139 Ensure_Valid
(Name
(Decl
));
5143 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5146 ----------------------
5147 -- Overlaps_Storage --
5148 ----------------------
5150 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
5151 Loc
: constant Source_Ptr
:= Sloc
(N
);
5152 X
: constant Node_Id
:= Prefix
(N
);
5153 Y
: constant Node_Id
:= First
(Expressions
(N
));
5157 X_Addr
, Y_Addr
: Node_Id
;
5159 -- The expressions for their integer addresses
5161 X_Size
, Y_Size
: Node_Id
;
5163 -- The expressions for their sizes
5168 -- Attribute expands into:
5170 -- (if X'Size = 0 or else Y'Size = 0 then
5173 -- (if X'Address <= Y'Address then
5174 -- (X'Address + X'Size - 1) >= Y'Address
5176 -- (Y'Address + Y'Size - 1) >= X'Address))
5178 -- with the proper address operations. We convert addresses to
5179 -- integer addresses to use predefined arithmetic. The size is
5180 -- expressed in storage units. We add copies of X_Addr and Y_Addr
5181 -- to prevent the appearance of the same node in two places in
5185 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5186 Make_Attribute_Reference
(Loc
,
5187 Attribute_Name
=> Name_Address
,
5188 Prefix
=> New_Copy_Tree
(X
)));
5191 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5192 Make_Attribute_Reference
(Loc
,
5193 Attribute_Name
=> Name_Address
,
5194 Prefix
=> New_Copy_Tree
(Y
)));
5197 Make_Op_Divide
(Loc
,
5199 Make_Attribute_Reference
(Loc
,
5200 Attribute_Name
=> Name_Size
,
5201 Prefix
=> New_Copy_Tree
(X
)),
5203 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5206 Make_Op_Divide
(Loc
,
5208 Make_Attribute_Reference
(Loc
,
5209 Attribute_Name
=> Name_Size
,
5210 Prefix
=> New_Copy_Tree
(Y
)),
5212 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5216 Left_Opnd
=> X_Addr
,
5217 Right_Opnd
=> Y_Addr
);
5219 -- Perform the rewriting
5222 Make_If_Expression
(Loc
, New_List
(
5224 -- Generate a check for zero-sized things like a null record with
5225 -- size zero or an array with zero length since they have no
5226 -- opportunity of overlapping.
5228 -- Without this check, a zero-sized object can trigger a false
5229 -- runtime result if it's compared against another object in
5230 -- its declarative region, due to the zero-sized object having
5231 -- the same address.
5237 Make_Attribute_Reference
(Loc
,
5238 Attribute_Name
=> Name_Size
,
5239 Prefix
=> New_Copy_Tree
(X
)),
5240 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5244 Make_Attribute_Reference
(Loc
,
5245 Attribute_Name
=> Name_Size
,
5246 Prefix
=> New_Copy_Tree
(Y
)),
5247 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))),
5249 New_Occurrence_Of
(Standard_False
, Loc
),
5251 -- Non-zero-size overlap check
5253 Make_If_Expression
(Loc
, New_List
(
5259 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
5261 Make_Op_Subtract
(Loc
,
5262 Left_Opnd
=> X_Size
,
5263 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5264 Right_Opnd
=> Y_Addr
),
5269 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
5271 Make_Op_Subtract
(Loc
,
5272 Left_Opnd
=> Y_Size
,
5273 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5274 Right_Opnd
=> X_Addr
))))));
5276 Analyze_And_Resolve
(N
, Standard_Boolean
);
5277 end Overlaps_Storage
;
5283 when Attribute_Output
=> Output
: declare
5284 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5285 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5293 -- If no underlying type, we have an error that will be diagnosed
5294 -- elsewhere, so here we just completely ignore the expansion.
5300 -- Stream operations can appear in user code even if the restriction
5301 -- No_Streams is active (for example, when instantiating a predefined
5302 -- container). In that case rewrite the attribute as a Raise to
5303 -- prevent any run-time use.
5305 if Restriction_Active
(No_Streams
) then
5307 Make_Raise_Program_Error
(Sloc
(N
),
5308 Reason
=> PE_Stream_Operation_Not_Allowed
));
5309 Set_Etype
(N
, Standard_Void_Type
);
5313 -- If TSS for Output is present, just call it
5315 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
5317 if Present
(Pname
) then
5321 -- If there is a Stream_Convert pragma, use it, we rewrite
5323 -- sourcetyp'Output (stream, Item)
5327 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5329 -- where strmwrite is the given Write function that converts an
5330 -- argument of type sourcetyp or a type acctyp, from which it is
5331 -- derived to type strmtyp. The conversion to acttyp is required
5332 -- for the derived case.
5334 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5336 if Present
(Prag
) then
5338 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
5339 Wfunc
:= Entity
(Expression
(Arg3
));
5342 Make_Attribute_Reference
(Loc
,
5343 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
5344 Attribute_Name
=> Name_Output
,
5345 Expressions
=> New_List
(
5346 Relocate_Node
(First
(Exprs
)),
5347 Make_Function_Call
(Loc
,
5348 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
5349 Parameter_Associations
=> New_List
(
5350 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
5351 Relocate_Node
(Next
(First
(Exprs
)))))))));
5358 elsif Default_Streaming_Unavailable
(U_Type
) then
5359 -- Do the same thing here as is done above in the
5360 -- case where a No_Streams restriction is active.
5363 Make_Raise_Program_Error
(Sloc
(N
),
5364 Reason
=> PE_Stream_Operation_Not_Allowed
));
5365 Set_Etype
(N
, Standard_Void_Type
);
5368 -- For elementary types, we call the W_xxx routine directly. Note
5369 -- that the effect of Write and Output is identical for the case
5370 -- of an elementary type (there are no discriminants or bounds).
5372 elsif Is_Elementary_Type
(U_Type
) then
5374 -- A special case arises if we have a defined _Write routine,
5375 -- since in this case we are required to call this routine.
5377 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Write
)) then
5378 Build_Record_Or_Elementary_Output_Procedure
5379 (Loc
, P_Type
, Decl
, Pname
);
5380 Insert_Action
(N
, Decl
);
5382 -- For normal cases, we call the W_xxx routine directly
5385 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
5392 elsif Is_Array_Type
(U_Type
) then
5393 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
5394 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
5396 -- Class-wide case, first output external tag, then dispatch
5397 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5399 elsif Is_Class_Wide_Type
(P_Type
) then
5401 -- No need to do anything else compiling under restriction
5402 -- No_Dispatching_Calls. During the semantic analysis we
5403 -- already notified such violation.
5405 if Restriction_Active
(No_Dispatching_Calls
) then
5410 Strm
: constant Node_Id
:= First
(Exprs
);
5411 Item
: constant Node_Id
:= Next
(Strm
);
5414 -- Ada 2005 (AI-344): Check that the accessibility level
5415 -- of the type of the output object is not deeper than
5416 -- that of the attribute's prefix type.
5418 -- if Get_Access_Level (Item'Tag)
5419 -- /= Get_Access_Level (P_Type'Tag)
5424 -- String'Output (Strm, External_Tag (Item'Tag));
5426 -- We cannot figure out a practical way to implement this
5427 -- accessibility check on virtual machines, so we omit it.
5429 if Ada_Version
>= Ada_2005
5430 and then Tagged_Type_Expansion
5433 Make_Implicit_If_Statement
(N
,
5437 Build_Get_Access_Level
(Loc
,
5438 Make_Attribute_Reference
(Loc
,
5441 Duplicate_Subexpr
(Item
,
5443 Attribute_Name
=> Name_Tag
)),
5446 Make_Integer_Literal
(Loc
,
5447 Type_Access_Level
(P_Type
))),
5450 New_List
(Make_Raise_Statement
(Loc
,
5452 RTE
(RE_Tag_Error
), Loc
)))));
5456 Make_Attribute_Reference
(Loc
,
5457 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
5458 Attribute_Name
=> Name_Output
,
5459 Expressions
=> New_List
(
5460 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
5461 Make_Function_Call
(Loc
,
5463 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
5464 Parameter_Associations
=> New_List
(
5465 Make_Attribute_Reference
(Loc
,
5468 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
5469 Attribute_Name
=> Name_Tag
))))));
5472 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5474 -- Tagged type case, use the primitive Output function
5476 elsif Is_Tagged_Type
(U_Type
) then
5477 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5479 -- All other record type cases, including protected records.
5480 -- The latter only arise for expander generated code for
5481 -- handling shared passive partition access.
5485 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5487 -- Ada 2005 (AI-216): Program_Error is raised when executing
5488 -- the default implementation of the Output attribute of an
5489 -- unchecked union type if the type lacks default discriminant
5492 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5494 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5497 Make_Raise_Program_Error
(Loc
,
5498 Reason
=> PE_Unchecked_Union_Restriction
));
5499 Set_Etype
(N
, Standard_Void_Type
);
5503 Build_Record_Or_Elementary_Output_Procedure
5504 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
5505 Insert_Action
(N
, Decl
);
5509 -- If we fall through, Pname is the name of the procedure to call
5511 Rewrite_Attribute_Proc_Call
(Pname
);
5518 -- For enumeration types, with a non-standard representation we generate
5519 -- a call to the _Rep_To_Pos function created when the type was frozen.
5520 -- The call has the form:
5522 -- _rep_to_pos (expr, flag)
5524 -- The parameter flag is True if range checks are enabled, causing
5525 -- Program_Error to be raised if the expression has an invalid
5526 -- representation, and False if range checks are suppressed.
5528 -- For enumeration types with a standard representation, Pos can be
5529 -- rewritten as a simple conversion with Conversion_OK set.
5531 -- For integer types, Pos is equivalent to a simple integer conversion
5532 -- and we rewrite it as such.
5534 when Attribute_Pos
=> Pos
: declare
5535 Expr
: constant Node_Id
:= First
(Exprs
);
5536 Etyp
: Entity_Id
:= Base_Type
(Ptyp
);
5539 -- Deal with zero/non-zero boolean values
5541 if Is_Boolean_Type
(Etyp
) then
5542 Adjust_Condition
(Expr
);
5543 Etyp
:= Standard_Boolean
;
5544 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5547 -- Case of enumeration type
5549 if Is_Enumeration_Type
(Etyp
) then
5551 -- Non-standard enumeration type (generate call)
5553 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5554 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5557 Make_Function_Call
(Loc
,
5559 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5560 Parameter_Associations
=> Exprs
)));
5562 -- Standard enumeration type (replace by conversion)
5564 -- This is simply a direct conversion from the enumeration type to
5565 -- the target integer type, which is treated by the back end as a
5566 -- normal integer conversion, treating the enumeration type as an
5567 -- integer, which is exactly what we want. We set Conversion_OK to
5568 -- make sure that the analyzer does not complain about what might
5569 -- be an illegal conversion.
5571 -- However the target type is universal integer in most cases,
5572 -- which is a very large type, so we first convert to a small
5573 -- signed integer type in order not to lose the size information.
5576 Rewrite
(N
, OK_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
5577 Convert_To_And_Rewrite
(Typ
, N
);
5581 -- Deal with integer types (replace by conversion)
5584 Rewrite
(N
, Convert_To
(Typ
, Expr
));
5587 Analyze_And_Resolve
(N
, Typ
);
5594 -- We leave the computation up to the back end, since we don't know what
5595 -- layout will be chosen if no component clause was specified.
5597 when Attribute_Position
=>
5598 Apply_Universal_Integer_Attribute_Checks
(N
);
5604 -- 1. Deal with enumeration types with holes.
5605 -- 2. For floating-point, generate call to attribute function.
5606 -- 3. For other cases, deal with constraint checking.
5608 when Attribute_Pred
=> Pred
: declare
5609 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5612 -- For enumeration types with non-standard representations, we
5613 -- expand typ'Pred (x) into:
5615 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5617 -- if the representation is non-contiguous, and just x - 1 if it is
5618 -- after having dealt with constraint checking.
5620 if Is_Enumeration_Type
(Etyp
)
5621 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5623 if Has_Contiguous_Rep
(Etyp
) then
5624 if not Range_Checks_Suppressed
(Ptyp
) then
5625 Set_Do_Range_Check
(First
(Exprs
), False);
5626 Expand_Pred_Succ_Attribute
(N
);
5630 Unchecked_Convert_To
(Etyp
,
5631 Make_Op_Subtract
(Loc
,
5633 Unchecked_Convert_To
(
5635 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
5638 Make_Integer_Literal
(Loc
, 1))));
5641 -- Add Boolean parameter depending on check suppression
5643 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5645 Make_Indexed_Component
(Loc
,
5648 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5649 Expressions
=> New_List
(
5650 Make_Op_Subtract
(Loc
,
5652 Make_Function_Call
(Loc
,
5655 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5656 Parameter_Associations
=> Exprs
),
5657 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5660 -- Suppress checks since they have all been done above
5662 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
5664 -- For floating-point, we transform 'Pred into a call to the Pred
5665 -- floating-point attribute function in Fat_xxx (xxx is root type).
5666 -- Note that this function takes care of the overflow case.
5668 elsif Is_Floating_Point_Type
(Ptyp
) then
5669 Expand_Fpt_Attribute_R
(N
);
5670 Analyze_And_Resolve
(N
, Typ
);
5672 -- For modular types, nothing to do (no overflow, since wraps)
5674 elsif Is_Modular_Integer_Type
(Ptyp
) then
5677 -- For other types, if argument is marked as needing a range check or
5678 -- overflow checking is enabled, we must generate a check.
5680 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5681 or else Do_Range_Check
(First
(Exprs
))
5683 Set_Do_Range_Check
(First
(Exprs
), False);
5684 Expand_Pred_Succ_Attribute
(N
);
5688 ----------------------------------
5689 -- Preelaborable_Initialization --
5690 ----------------------------------
5692 when Attribute_Preelaborable_Initialization
=>
5694 -- This attribute should already be folded during analysis, but if
5695 -- for some reason it hasn't been, we fold it now.
5700 (Boolean'Pos (Has_Preelaborable_Initialization
(Ptyp
))),
5707 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5709 -- We rewrite X'Priority as the following run-time call:
5711 -- Get_Ceiling (X._Object)
5713 -- Note that although X'Priority is notionally an object, it is quite
5714 -- deliberately not defined as an aliased object in the RM. This means
5715 -- that it works fine to rewrite it as a call, without having to worry
5716 -- about complications that would other arise from X'Priority'Access,
5717 -- which is illegal, because of the lack of aliasing.
5719 when Attribute_Priority
=> Priority
: declare
5721 New_Itype
: Entity_Id
;
5722 Object_Parm
: Node_Id
;
5723 Prottyp
: Entity_Id
;
5728 -- Look for the enclosing protected type
5730 Prottyp
:= Current_Scope
;
5731 while not Is_Protected_Type
(Prottyp
) loop
5732 Prottyp
:= Scope
(Prottyp
);
5735 pragma Assert
(Is_Protected_Type
(Prottyp
));
5737 -- Generate the actual of the call
5739 Subprg
:= Current_Scope
;
5740 while not (Is_Subprogram_Or_Entry
(Subprg
)
5741 and then Present
(Protected_Body_Subprogram
(Subprg
)))
5743 Subprg
:= Scope
(Subprg
);
5746 -- Use of 'Priority inside protected entries and barriers (in both
5747 -- cases the type of the first formal of their expanded subprogram
5750 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5753 -- In the expansion of protected entries the type of the first
5754 -- formal of the Protected_Body_Subprogram is an Address. In order
5755 -- to reference the _object component we generate:
5757 -- type T is access p__ptTV;
5760 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5761 Set_Etype
(New_Itype
, New_Itype
);
5762 Set_Directly_Designated_Type
(New_Itype
,
5763 Corresponding_Record_Type
(Prottyp
));
5764 Freeze_Itype
(New_Itype
, N
);
5767 -- T!(O)._object'unchecked_access
5770 Make_Attribute_Reference
(Loc
,
5772 Make_Selected_Component
(Loc
,
5774 Unchecked_Convert_To
(New_Itype
,
5776 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5778 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5779 Attribute_Name
=> Name_Unchecked_Access
);
5781 -- Use of 'Priority inside a protected subprogram
5785 Make_Attribute_Reference
(Loc
,
5787 Make_Selected_Component
(Loc
,
5790 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5792 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5793 Attribute_Name
=> Name_Unchecked_Access
);
5796 -- Select the appropriate run-time subprogram
5798 if Has_Entries
(Prottyp
) then
5799 RT_Subprg
:= RO_PE_Get_Ceiling
;
5801 RT_Subprg
:= RE_Get_Ceiling
;
5805 Make_Function_Call
(Loc
,
5807 New_Occurrence_Of
(RTE
(RT_Subprg
), Loc
),
5808 Parameter_Associations
=> New_List
(Object_Parm
));
5812 -- Avoid the generation of extra checks on the pointer to the
5813 -- protected object.
5815 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5822 when Attribute_Put_Image
=> Put_Image
: declare
5824 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Pref
));
5829 -- If no underlying type, we have an error that will be diagnosed
5830 -- elsewhere, so here we just completely ignore the expansion.
5836 -- If there is a TSS for Put_Image, just call it. This is true for
5837 -- tagged types (if enabled) and if there is a user-specified
5840 Pname
:= TSS
(U_Type
, TSS_Put_Image
);
5842 if Is_Tagged_Type
(U_Type
) and then Is_Derived_Type
(U_Type
) then
5843 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5845 Pname
:= Find_Inherited_TSS
(U_Type
, TSS_Put_Image
);
5850 -- If Put_Image is disabled, call the "unknown" version
5852 if not Enable_Put_Image
(U_Type
) then
5853 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5857 -- For elementary types, we call the routine in System.Put_Images
5860 elsif Is_Elementary_Type
(U_Type
) then
5861 Rewrite
(N
, Build_Elementary_Put_Image_Call
(N
));
5865 elsif Is_Standard_String_Type
(U_Type
) then
5866 Rewrite
(N
, Build_String_Put_Image_Call
(N
));
5870 elsif Is_Array_Type
(U_Type
) then
5871 Build_Array_Put_Image_Procedure
(N
, U_Type
, Decl
, Pname
);
5872 Insert_Action
(N
, Decl
);
5874 -- Tagged type case, use the primitive Put_Image function. Note
5875 -- that this will dispatch in the class-wide case which is what we
5878 elsif Is_Tagged_Type
(U_Type
) then
5879 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5881 -- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
5882 -- because we might be deriving from a predefined type, which
5883 -- currently has Enable_Put_Image False.
5886 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5891 elsif Is_Protected_Type
(U_Type
) then
5892 Rewrite
(N
, Build_Protected_Put_Image_Call
(N
));
5896 elsif Is_Task_Type
(U_Type
) then
5897 Rewrite
(N
, Build_Task_Put_Image_Call
(N
));
5901 -- All other record type cases
5904 pragma Assert
(Is_Record_Type
(U_Type
));
5905 Build_Record_Put_Image_Procedure
5906 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5907 Insert_Action
(N
, Decl
);
5911 -- If we fall through, Pname is the procedure to be called
5913 Rewrite_Attribute_Proc_Call
(Pname
);
5920 when Attribute_Range_Length
=>
5922 -- The only special processing required is for the case where
5923 -- Range_Length is applied to an enumeration type with holes.
5924 -- In this case we transform
5930 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5932 -- So that the result reflects the proper Pos values instead
5933 -- of the underlying representations.
5935 if Is_Enumeration_Type
(Ptyp
)
5936 and then Has_Non_Standard_Rep
(Ptyp
)
5941 Make_Op_Subtract
(Loc
,
5943 Make_Attribute_Reference
(Loc
,
5944 Attribute_Name
=> Name_Pos
,
5945 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5946 Expressions
=> New_List
(
5947 Make_Attribute_Reference
(Loc
,
5948 Attribute_Name
=> Name_Last
,
5950 New_Occurrence_Of
(Ptyp
, Loc
)))),
5953 Make_Attribute_Reference
(Loc
,
5954 Attribute_Name
=> Name_Pos
,
5955 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5956 Expressions
=> New_List
(
5957 Make_Attribute_Reference
(Loc
,
5958 Attribute_Name
=> Name_First
,
5960 New_Occurrence_Of
(Ptyp
, Loc
))))),
5962 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5964 Analyze_And_Resolve
(N
, Typ
);
5966 -- For all other cases, the attribute is handled by the back end, but
5967 -- we need to deal with the case of the range check on a universal
5971 Apply_Universal_Integer_Attribute_Checks
(N
);
5978 when Attribute_Reduce
=>
5980 Loc
: constant Source_Ptr
:= Sloc
(N
);
5981 E1
: constant Node_Id
:= First
(Expressions
(N
));
5982 E2
: constant Node_Id
:= Next
(E1
);
5983 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
5984 Typ
: constant Entity_Id
:= Etype
(N
);
5989 function Build_Stat
(Comp
: Node_Id
) return Node_Id
;
5990 -- The reducer can be a function, a procedure whose first
5991 -- parameter is in-out, or an attribute that is a function,
5992 -- which (for now) can only be Min/Max. This subprogram
5993 -- builds the corresponding computation for the generated loop.
5999 function Build_Stat
(Comp
: Node_Id
) return Node_Id
is
6001 if Nkind
(E1
) = N_Attribute_Reference
then
6002 Stat
:= Make_Assignment_Statement
(Loc
,
6003 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
6004 Expression
=> Make_Attribute_Reference
(Loc
,
6005 Attribute_Name
=> Attribute_Name
(E1
),
6006 Prefix
=> New_Copy
(Prefix
(E1
)),
6007 Expressions
=> New_List
(
6008 New_Occurrence_Of
(Bnn
, Loc
),
6011 elsif Ekind
(Entity
(E1
)) = E_Procedure
then
6012 Stat
:= Make_Procedure_Call_Statement
(Loc
,
6013 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
6014 Parameter_Associations
=> New_List
(
6015 New_Occurrence_Of
(Bnn
, Loc
),
6018 Stat
:= Make_Assignment_Statement
(Loc
,
6019 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
6020 Expression
=> Make_Function_Call
(Loc
,
6021 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
6022 Parameter_Associations
=> New_List
(
6023 New_Occurrence_Of
(Bnn
, Loc
),
6030 -- If the prefix is an aggregate, its unique component is an
6031 -- Iterated_Element, and we create a loop out of its iterator.
6032 -- The iterated_component_association is parsed as a loop parameter
6033 -- specification with "in" or as a container iterator with "of".
6036 if Nkind
(Prefix
(N
)) = N_Aggregate
then
6038 Stream
: constant Node_Id
:=
6039 First
(Component_Associations
(Prefix
(N
)));
6040 Expr
: constant Node_Id
:= Expression
(Stream
);
6041 Id
: constant Node_Id
:= Defining_Identifier
(Stream
);
6042 It_Spec
: constant Node_Id
:=
6043 Iterator_Specification
(Stream
);
6048 -- Iteration may be given by an element iterator:
6050 if Nkind
(Stream
) = N_Iterated_Component_Association
6051 and then Present
(It_Spec
)
6052 and then Of_Present
(It_Spec
)
6055 Make_Iteration_Scheme
(Loc
,
6056 Iterator_Specification
=>
6057 Relocate_Node
(It_Spec
),
6058 Loop_Parameter_Specification
=> Empty
);
6061 Ch
:= First
(Discrete_Choices
(Stream
));
6063 Make_Iteration_Scheme
(Loc
,
6064 Iterator_Specification
=> Empty
,
6065 Loop_Parameter_Specification
=>
6066 Make_Loop_Parameter_Specification
(Loc
,
6067 Defining_Identifier
=> New_Copy
(Id
),
6068 Discrete_Subtype_Definition
=>
6069 Relocate_Node
(Ch
)));
6072 New_Loop
:= Make_Loop_Statement
(Loc
,
6073 Iteration_Scheme
=> Iter
,
6076 New_List
(Build_Stat
(Relocate_Node
(Expr
))));
6080 -- If the prefix is a name, we construct an element iterator
6081 -- over it. Its expansion will verify that it is an array or
6082 -- a container with the proper aspects.
6086 Elem
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
6090 Make_Iterator_Specification
(Loc
,
6091 Defining_Identifier
=> Elem
,
6092 Name
=> Relocate_Node
(Prefix
(N
)),
6093 Subtype_Indication
=> Empty
);
6094 Set_Of_Present
(Iter
);
6096 New_Loop
:= Make_Loop_Statement
(Loc
,
6098 Make_Iteration_Scheme
(Loc
,
6099 Iterator_Specification
=> Iter
,
6100 Loop_Parameter_Specification
=> Empty
),
6102 Statements
=> New_List
(
6103 Build_Stat
(New_Occurrence_Of
(Elem
, Loc
))));
6108 Make_Expression_With_Actions
(Loc
,
6109 Actions
=> New_List
(
6110 Make_Object_Declaration
(Loc
,
6111 Defining_Identifier
=> Bnn
,
6112 Object_Definition
=>
6113 New_Occurrence_Of
(Typ
, Loc
),
6114 Expression
=> Relocate_Node
(E2
)), New_Loop
),
6115 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
6116 Analyze_And_Resolve
(N
, Typ
);
6123 when Attribute_Read
=> Read
: declare
6124 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6125 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
6126 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6136 -- If no underlying type, we have an error that will be diagnosed
6137 -- elsewhere, so here we just completely ignore the expansion.
6143 -- Stream operations can appear in user code even if the restriction
6144 -- No_Streams is active (for example, when instantiating a predefined
6145 -- container). In that case rewrite the attribute as a Raise to
6146 -- prevent any run-time use.
6148 if Restriction_Active
(No_Streams
) then
6150 Make_Raise_Program_Error
(Sloc
(N
),
6151 Reason
=> PE_Stream_Operation_Not_Allowed
));
6152 Set_Etype
(N
, B_Type
);
6156 -- The simple case, if there is a TSS for Read, just call it
6158 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
6160 if Present
(Pname
) then
6164 -- If there is a Stream_Convert pragma, use it, we rewrite
6166 -- sourcetyp'Read (stream, Item)
6170 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
6172 -- where strmread is the given Read function that converts an
6173 -- argument of type strmtyp to type sourcetyp or a type from which
6174 -- it is derived. The conversion to sourcetyp is required in the
6177 -- A special case arises if Item is a type conversion in which
6178 -- case, we have to expand to:
6180 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
6182 -- where Itemx is the expression of the type conversion (i.e.
6183 -- the actual object), and typex is the type of Itemx.
6185 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6187 if Present
(Prag
) then
6188 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
6189 Rfunc
:= Entity
(Expression
(Arg2
));
6190 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6192 OK_Convert_To
(B_Type
,
6193 Make_Function_Call
(Loc
,
6194 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
6195 Parameter_Associations
=> New_List
(
6196 Make_Attribute_Reference
(Loc
,
6199 (Etype
(First_Formal
(Rfunc
)), Loc
),
6200 Attribute_Name
=> Name_Input
,
6201 Expressions
=> New_List
(
6202 Relocate_Node
(First
(Exprs
)))))));
6204 if Nkind
(Lhs
) = N_Type_Conversion
then
6205 Lhs
:= Expression
(Lhs
);
6206 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6210 Make_Assignment_Statement
(Loc
,
6212 Expression
=> Rhs
));
6213 Set_Assignment_OK
(Lhs
);
6219 elsif Default_Streaming_Unavailable
(U_Type
) then
6220 -- Do the same thing here as is done above in the
6221 -- case where a No_Streams restriction is active.
6224 Make_Raise_Program_Error
(Sloc
(N
),
6225 Reason
=> PE_Stream_Operation_Not_Allowed
));
6226 Set_Etype
(N
, B_Type
);
6229 -- For elementary types, we call the I_xxx routine using the first
6230 -- parameter and then assign the result into the second parameter.
6231 -- We set Assignment_OK to deal with the conversion case.
6233 elsif Is_Elementary_Type
(U_Type
) then
6239 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6240 Rhs
:= Build_Elementary_Input_Call
(N
);
6242 if Nkind
(Lhs
) = N_Type_Conversion
then
6243 Lhs
:= Expression
(Lhs
);
6244 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6247 Set_Assignment_OK
(Lhs
);
6250 Make_Assignment_Statement
(Loc
,
6252 Expression
=> Rhs
));
6260 elsif Is_Array_Type
(U_Type
) then
6261 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
6262 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
6264 -- Tagged type case, use the primitive Read function. Note that
6265 -- this will dispatch in the class-wide case which is what we want
6267 elsif Is_Tagged_Type
(U_Type
) then
6268 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
6270 -- All other record type cases, including protected records. The
6271 -- latter only arise for expander generated code for handling
6272 -- shared passive partition access.
6276 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
6278 -- Ada 2005 (AI-216): Program_Error is raised when executing
6279 -- the default implementation of the Read attribute of an
6280 -- Unchecked_Union type. We replace the attribute with a
6281 -- raise statement (rather than inserting it before) to handle
6282 -- properly the case of an unchecked union that is a record
6285 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
6287 Make_Raise_Program_Error
(Loc
,
6288 Reason
=> PE_Unchecked_Union_Restriction
));
6289 Set_Etype
(N
, B_Type
);
6293 if Has_Defaulted_Discriminants
(U_Type
) then
6294 Build_Mutable_Record_Read_Procedure
6295 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6297 Build_Record_Read_Procedure
6298 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6301 Insert_Action
(N
, Decl
);
6305 Rewrite_Attribute_Proc_Call
(Pname
);
6312 -- Ref is identical to To_Address, see To_Address for processing
6318 -- Transforms 'Remainder into a call to the floating-point attribute
6319 -- function Remainder in Fat_xxx (where xxx is the root type)
6321 when Attribute_Remainder
=>
6322 Expand_Fpt_Attribute_RR
(N
);
6328 -- Transform 'Result into reference to _Result formal. At the point
6329 -- where a legal 'Result attribute is expanded, we know that we are in
6330 -- the context of a _Postcondition function with a _Result parameter.
6332 when Attribute_Result
=>
6333 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
6334 Analyze_And_Resolve
(N
, Typ
);
6340 -- The handling of the Round attribute is delicate when the operand is
6341 -- universal fixed. In this case, the processing in Sem_Attr introduced
6342 -- a conversion to universal real, reflecting the semantics of Round,
6343 -- but we do not want anything to do with universal real at run time,
6344 -- since this corresponds to using floating-point arithmetic.
6346 -- What we have now is that the Etype of the Round attribute correctly
6347 -- indicates the final result type. The operand of the Round is the
6348 -- conversion to universal real, described above, and the operand of
6349 -- this conversion is the actual operand of Round, which may be the
6350 -- special case of a fixed point multiplication or division.
6352 -- The expander will expand first the operand of the conversion, then
6353 -- the conversion, and finally the round attribute itself, since we
6354 -- always work inside out. But we cannot simply process naively in this
6355 -- order. In the semantic world where universal fixed and real really
6356 -- exist and have infinite precision, there is no problem, but in the
6357 -- implementation world, where universal real is a floating-point type,
6358 -- we would get the wrong result.
6360 -- So the approach is as follows. When expanding a multiply or divide
6361 -- whose type is universal fixed, Fixup_Universal_Fixed_Operation will
6362 -- look up and skip the conversion to universal real if its parent is
6363 -- a Round attribute, taking information from this attribute node. In
6364 -- the other cases, Expand_N_Type_Conversion does the same by looking
6365 -- at its parent to see if it is a Round attribute, before calling the
6366 -- fixed-point expansion routine.
6368 -- This means that by the time we get to expanding the Round attribute
6369 -- itself, the Round is nothing more than a type conversion (and will
6370 -- often be a null type conversion), so we just replace it with the
6371 -- appropriate conversion operation.
6373 when Attribute_Round
=>
6374 if Etype
(First
(Exprs
)) = Etype
(N
) then
6375 Rewrite
(N
, Relocate_Node
(First
(Exprs
)));
6377 Rewrite
(N
, Convert_To
(Etype
(N
), First
(Exprs
)));
6378 Set_Rounded_Result
(N
);
6380 Analyze_And_Resolve
(N
);
6386 -- Transforms 'Rounding into a call to the floating-point attribute
6387 -- function Rounding in Fat_xxx (where xxx is the root type)
6388 -- Expansion is avoided for cases the back end can handle directly.
6390 when Attribute_Rounding
=>
6391 if not Is_Inline_Floating_Point_Attribute
(N
) then
6392 Expand_Fpt_Attribute_R
(N
);
6399 -- Transforms 'Scaling into a call to the floating-point attribute
6400 -- function Scaling in Fat_xxx (where xxx is the root type)
6402 when Attribute_Scaling
=>
6403 Expand_Fpt_Attribute_RI
(N
);
6405 ----------------------------------------
6406 -- Simple_Storage_Pool & Storage_Pool --
6407 ----------------------------------------
6409 when Attribute_Simple_Storage_Pool | Attribute_Storage_Pool
=>
6411 Make_Type_Conversion
(Loc
,
6412 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
6413 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
6414 Analyze_And_Resolve
(N
, Typ
);
6420 when Attribute_Object_Size
6422 | Attribute_Value_Size
6423 | Attribute_VADS_Size
6429 -- Processing for VADS_Size case. Note that this processing
6430 -- removes all traces of VADS_Size from the tree, and completes
6431 -- all required processing for VADS_Size by translating the
6432 -- attribute reference to an appropriate Size or Object_Size
6435 if Id
= Attribute_VADS_Size
6436 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
6438 -- If the size is specified, then we simply use the specified
6439 -- size. This applies to both types and objects. The size of an
6440 -- object can be specified in the following ways:
6442 -- An explicit size clause is given for an object
6443 -- A component size is specified for an indexed component
6444 -- A component clause is specified for a selected component
6445 -- The object is a component of a packed composite object
6447 -- If the size is specified, then VADS_Size of an object
6449 if (Is_Entity_Name
(Pref
)
6450 and then Present
(Size_Clause
(Entity
(Pref
))))
6452 (Nkind
(Pref
) = N_Component_Clause
6453 and then (Present
(Component_Clause
6454 (Entity
(Selector_Name
(Pref
))))
6455 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6457 (Nkind
(Pref
) = N_Indexed_Component
6458 and then (Known_Component_Size
(Etype
(Prefix
(Pref
)))
6459 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6461 Set_Attribute_Name
(N
, Name_Size
);
6463 -- Otherwise if we have an object rather than a type, then
6464 -- the VADS_Size attribute applies to the type of the object,
6465 -- rather than the object itself. This is one of the respects
6466 -- in which VADS_Size differs from Size.
6469 if (not Is_Entity_Name
(Pref
)
6470 or else not Is_Type
(Entity
(Pref
)))
6471 and then (Is_Scalar_Type
(Ptyp
)
6472 or else Is_Constrained
(Ptyp
))
6474 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
6477 -- For a scalar type for which no size was explicitly given,
6478 -- VADS_Size means Object_Size. This is the other respect in
6479 -- which VADS_Size differs from Size.
6481 if Is_Scalar_Type
(Ptyp
)
6482 and then No
(Size_Clause
(Ptyp
))
6484 Set_Attribute_Name
(N
, Name_Object_Size
);
6486 -- In all other cases, Size and VADS_Size are the same
6489 Set_Attribute_Name
(N
, Name_Size
);
6494 -- If the prefix is X'Class, transform it into a direct reference
6495 -- to the class-wide type, because the back end must not see a
6496 -- 'Class reference.
6498 if Is_Entity_Name
(Pref
)
6499 and then Is_Class_Wide_Type
(Entity
(Pref
))
6501 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
6504 -- For X'Size applied to an object of a class-wide type, transform
6505 -- X'Size into a call to the primitive operation _Size applied to
6508 elsif Is_Class_Wide_Type
(Ptyp
) then
6510 -- No need to do anything else compiling under restriction
6511 -- No_Dispatching_Calls. During the semantic analysis we
6512 -- already noted this restriction violation.
6514 if Restriction_Active
(No_Dispatching_Calls
) then
6519 Make_Function_Call
(Loc
,
6521 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
6522 Parameter_Associations
=> New_List
(Pref
));
6524 if Typ
/= Standard_Long_Long_Integer
then
6526 -- The context is a specific integer type with which the
6527 -- original attribute was compatible. The function has a
6528 -- specific type as well, so to preserve the compatibility
6529 -- we must convert explicitly.
6531 New_Node
:= Convert_To
(Typ
, New_Node
);
6534 Rewrite
(N
, New_Node
);
6535 Analyze_And_Resolve
(N
, Typ
);
6539 -- Call Expand_Size_Attribute to do the final part of the
6540 -- expansion which is shared with GNATprove expansion.
6542 Expand_Size_Attribute
(N
);
6549 when Attribute_Storage_Size
=> Storage_Size
: declare
6550 Alloc_Op
: Entity_Id
:= Empty
;
6554 -- Access type case, always go to the root type
6556 -- The case of access types results in a value of zero for the case
6557 -- where no storage size attribute clause has been given. If a
6558 -- storage size has been given, then the attribute is converted
6559 -- to a reference to the variable used to hold this value.
6561 if Is_Access_Type
(Ptyp
) then
6562 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
6565 Make_Attribute_Reference
(Loc
,
6566 Prefix
=> New_Occurrence_Of
6567 (Etype
(Storage_Size_Variable
(Root_Type
(Ptyp
))), Loc
),
6568 Attribute_Name
=> Name_Max
,
6569 Expressions
=> New_List
(
6570 Make_Integer_Literal
(Loc
, 0),
6572 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
6574 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
6576 -- If the access type is associated with a simple storage pool
6577 -- object, then attempt to locate the optional Storage_Size
6578 -- function of the simple storage pool type. If not found,
6579 -- then the result will default to zero.
6581 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
6582 Name_Simple_Storage_Pool_Type
))
6585 Pool_Type
: constant Entity_Id
:=
6586 Base_Type
(Etype
(Entity
(N
)));
6589 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
6590 while Present
(Alloc_Op
) loop
6591 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
6592 and then Present
(First_Formal
(Alloc_Op
))
6593 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
6598 Alloc_Op
:= Homonym
(Alloc_Op
);
6602 -- In the normal Storage_Pool case, retrieve the primitive
6603 -- function associated with the pool type.
6608 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
6609 Attribute_Name
(N
));
6612 -- If Storage_Size wasn't found (can only occur in the simple
6613 -- storage pool case), then simply use zero for the result.
6615 if No
(Alloc_Op
) then
6616 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6618 -- Otherwise, rewrite the allocator as a call to pool type's
6619 -- Storage_Size function.
6624 Make_Function_Call
(Loc
,
6626 New_Occurrence_Of
(Alloc_Op
, Loc
),
6628 Parameter_Associations
=> New_List
(
6630 (Associated_Storage_Pool
6631 (Root_Type
(Ptyp
)), Loc
)))));
6635 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6638 Analyze_And_Resolve
(N
, Typ
);
6640 -- For tasks, we retrieve the size directly from the TCB. The
6641 -- size may depend on a discriminant of the type, and therefore
6642 -- can be a per-object expression, so type-level information is
6643 -- not sufficient in general. There are four cases to consider:
6645 -- a) If the attribute appears within a task body, the designated
6646 -- TCB is obtained by a call to Self.
6648 -- b) If the prefix of the attribute is the name of a task object,
6649 -- the designated TCB is the one stored in the corresponding record.
6651 -- c) If the prefix is a task type, the size is obtained from the
6652 -- size variable created for each task type
6654 -- d) If no Storage_Size was specified for the type, there is no
6655 -- size variable, and the value is a system-specific default.
6658 if In_Open_Scopes
(Ptyp
) then
6660 -- Storage_Size (Self)
6664 Make_Function_Call
(Loc
,
6666 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6667 Parameter_Associations
=>
6669 Make_Function_Call
(Loc
,
6671 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6673 elsif not Is_Entity_Name
(Pref
)
6674 or else not Is_Type
(Entity
(Pref
))
6676 -- Storage_Size (Rec (Obj).Size)
6680 Make_Function_Call
(Loc
,
6682 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6683 Parameter_Associations
=>
6685 Make_Selected_Component
(Loc
,
6687 Unchecked_Convert_To
(
6688 Corresponding_Record_Type
(Ptyp
),
6689 New_Copy_Tree
(Pref
)),
6691 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6693 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6695 -- Static Storage_Size pragma given for type: retrieve value
6696 -- from its allocated storage variable.
6700 Make_Function_Call
(Loc
,
6701 Name
=> New_Occurrence_Of
(
6702 RTE
(RE_Adjust_Storage_Size
), Loc
),
6703 Parameter_Associations
=>
6706 Storage_Size_Variable
(Ptyp
), Loc
)))));
6708 -- Get system default
6712 Make_Function_Call
(Loc
,
6715 RTE
(RE_Default_Stack_Size
), Loc
))));
6718 Analyze_And_Resolve
(N
, Typ
);
6726 when Attribute_Stream_Size
=>
6728 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6729 Analyze_And_Resolve
(N
, Typ
);
6735 -- 1. Deal with enumeration types with holes.
6736 -- 2. For floating-point, generate call to attribute function.
6737 -- 3. For other cases, deal with constraint checking.
6739 when Attribute_Succ
=> Succ
: declare
6740 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6743 -- For enumeration types with non-standard representations, we
6744 -- expand typ'Pred (x) into:
6746 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6748 -- if the representation is non-contiguous, and just x + 1 if it is
6749 -- after having dealt with constraint checking.
6751 if Is_Enumeration_Type
(Etyp
)
6752 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6754 if Has_Contiguous_Rep
(Etyp
) then
6755 if not Range_Checks_Suppressed
(Ptyp
) then
6756 Set_Do_Range_Check
(First
(Exprs
), False);
6757 Expand_Pred_Succ_Attribute
(N
);
6761 Unchecked_Convert_To
(Etyp
,
6764 Unchecked_Convert_To
(
6766 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
6769 Make_Integer_Literal
(Loc
, 1))));
6772 -- Add Boolean parameter depending on check suppression
6774 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6776 Make_Indexed_Component
(Loc
,
6779 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6780 Expressions
=> New_List
(
6783 Make_Function_Call
(Loc
,
6786 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6787 Parameter_Associations
=> Exprs
),
6788 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6791 -- Suppress checks since they have all been done above
6793 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
6795 -- For floating-point, we transform 'Succ into a call to the Succ
6796 -- floating-point attribute function in Fat_xxx (xxx is root type).
6797 -- Note that this function takes care of the overflow case.
6799 elsif Is_Floating_Point_Type
(Ptyp
) then
6800 Expand_Fpt_Attribute_R
(N
);
6801 Analyze_And_Resolve
(N
, Typ
);
6803 -- For modular types, nothing to do (no overflow, since wraps)
6805 elsif Is_Modular_Integer_Type
(Ptyp
) then
6808 -- For other types, if argument is marked as needing a range check or
6809 -- overflow checking is enabled, we must generate a check.
6811 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6812 or else Do_Range_Check
(First
(Exprs
))
6814 Set_Do_Range_Check
(First
(Exprs
), False);
6815 Expand_Pred_Succ_Attribute
(N
);
6823 -- Transforms X'Tag into a direct reference to the tag of X
6825 when Attribute_Tag
=> Tag
: declare
6827 Prefix_Is_Type
: Boolean;
6830 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6831 Ttyp
:= Entity
(Pref
);
6832 Prefix_Is_Type
:= True;
6835 Prefix_Is_Type
:= False;
6838 -- In the case of a class-wide equivalent type without a parent,
6839 -- the _Tag component has been built in Make_CW_Equivalent_Type
6840 -- manually and must be referenced directly.
6842 if Ekind
(Ttyp
) = E_Class_Wide_Subtype
6843 and then Present
(Equivalent_Type
(Ttyp
))
6844 and then No
(Parent_Subtype
(Equivalent_Type
(Ttyp
)))
6846 Ttyp
:= Equivalent_Type
(Ttyp
);
6848 -- In all the other cases of class-wide type, including an equivalent
6849 -- type with a parent, the _Tag component ultimately present is that
6850 -- of the root type.
6852 elsif Is_Class_Wide_Type
(Ttyp
) then
6853 Ttyp
:= Root_Type
(Ttyp
);
6856 Ttyp
:= Underlying_Type
(Ttyp
);
6858 -- Ada 2005: The type may be a synchronized tagged type, in which
6859 -- case the tag information is stored in the corresponding record.
6861 if Is_Concurrent_Type
(Ttyp
) then
6862 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6865 if Prefix_Is_Type
then
6867 -- For VMs we leave the type attribute unexpanded because
6868 -- there's not a dispatching table to reference.
6870 if Tagged_Type_Expansion
then
6872 Unchecked_Convert_To
(RTE
(RE_Tag
),
6874 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6875 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6878 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6879 -- references the primary tag of the actual object. If 'Tag is
6880 -- applied to class-wide interface objects we generate code that
6881 -- displaces "this" to reference the base of the object.
6883 elsif Comes_From_Source
(N
)
6884 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6885 and then Is_Interface
(Underlying_Type
(Etype
(Prefix
(N
))))
6888 -- (To_Tag_Ptr (Prefix'Address)).all
6890 -- Note that Prefix'Address is recursively expanded into a call
6891 -- to Base_Address (Obj.Tag)
6893 -- Not needed for VM targets, since all handled by the VM
6895 if Tagged_Type_Expansion
then
6897 Make_Explicit_Dereference
(Loc
,
6898 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6899 Make_Attribute_Reference
(Loc
,
6900 Prefix
=> Relocate_Node
(Pref
),
6901 Attribute_Name
=> Name_Address
))));
6902 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6907 Make_Selected_Component
(Loc
,
6908 Prefix
=> Relocate_Node
(Pref
),
6910 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6911 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6919 -- Transforms 'Terminated attribute into a call to Terminated function
6921 when Attribute_Terminated
=> Terminated
: begin
6923 -- The prefix of Terminated is of a task interface class-wide type.
6925 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6927 if Ada_Version
>= Ada_2005
6928 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6929 and then Is_Interface
(Ptyp
)
6930 and then Is_Task_Interface
(Ptyp
)
6933 Make_Function_Call
(Loc
,
6935 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6936 Parameter_Associations
=> New_List
(
6937 Unchecked_Convert_To
6938 (RTE
(RO_ST_Task_Id
),
6939 Build_Disp_Get_Task_Id_Call
(Pref
)))));
6941 elsif Restricted_Profile
then
6943 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6947 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6950 Analyze_And_Resolve
(N
, Standard_Boolean
);
6957 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6958 -- unchecked conversion from (integral) type of X to type address. If
6959 -- the To_Address is a static expression, the transformed expression
6960 -- also needs to be static, because we do some legality checks (e.g.
6961 -- for Thread_Local_Storage) after this transformation.
6964 | Attribute_To_Address
6966 To_Address
: declare
6967 Is_Static
: constant Boolean := Is_Static_Expression
(N
);
6971 Unchecked_Convert_To
(RTE
(RE_Address
),
6972 Relocate_Node
(First
(Exprs
))));
6973 Set_Is_Static_Expression
(N
, Is_Static
);
6975 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6982 when Attribute_To_Any
=> To_Any
: declare
6983 Decls
: constant List_Id
:= New_List
;
6989 Relocate_Node
(First
(Exprs
))), Decls
));
6990 Insert_Actions
(N
, Decls
);
6991 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6998 -- Transforms 'Truncation into a call to the floating-point attribute
6999 -- function Truncation in Fat_xxx (where xxx is the root type).
7000 -- Expansion is avoided for cases the back end can handle directly.
7002 when Attribute_Truncation
=>
7003 if not Is_Inline_Floating_Point_Attribute
(N
) then
7004 Expand_Fpt_Attribute_R
(N
);
7011 when Attribute_TypeCode
=> TypeCode
: declare
7012 Decls
: constant List_Id
:= New_List
;
7014 Rewrite
(N
, Build_TypeCode_Call
(Loc
, Ptyp
, Decls
));
7015 Insert_Actions
(N
, Decls
);
7016 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
7019 -----------------------
7020 -- Unbiased_Rounding --
7021 -----------------------
7023 -- Transforms 'Unbiased_Rounding into a call to the floating-point
7024 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
7025 -- root type). Expansion is avoided for cases the back end can handle
7028 when Attribute_Unbiased_Rounding
=>
7029 if not Is_Inline_Floating_Point_Attribute
(N
) then
7030 Expand_Fpt_Attribute_R
(N
);
7037 when Attribute_Update
=>
7038 Expand_Update_Attribute
(N
);
7044 -- The processing for VADS_Size is shared with Size
7050 -- For enumeration types with a non-standard representation we use the
7051 -- _Pos_To_Rep array that was created when the type was frozen, unless
7052 -- the representation is contiguous in which case we use an addition.
7054 -- For enumeration types with a standard representation, Val can be
7055 -- rewritten as a simple conversion with Conversion_OK set.
7057 -- For integer types, Val is equivalent to a simple integer conversion
7058 -- and we rewrite it as such.
7060 when Attribute_Val
=> Val
: declare
7061 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
7062 Expr
: constant Node_Id
:= First
(Exprs
);
7066 -- Case of enumeration type
7068 if Is_Enumeration_Type
(Etyp
) then
7070 -- Non-contiguous non-standard enumeration type
7072 if Present
(Enum_Pos_To_Rep
(Etyp
))
7073 and then not Has_Contiguous_Rep
(Etyp
)
7076 Make_Indexed_Component
(Loc
,
7078 New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
7079 Expressions
=> New_List
(
7080 Convert_To
(Standard_Integer
, Expr
))));
7082 Analyze_And_Resolve
(N
, Typ
);
7084 -- Standard or contiguous non-standard enumeration type
7087 -- If the argument is marked as requiring a range check then
7088 -- generate it here, after looking through a conversion to
7089 -- universal integer, if any.
7091 if Do_Range_Check
(Expr
) then
7092 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7093 Rtyp
:= Enum_Pos_To_Rep
(Etyp
);
7098 if Nkind
(Expr
) = N_Type_Conversion
7099 and then Entity
(Subtype_Mark
(Expr
)) = Universal_Integer
7101 Generate_Range_Check
7102 (Expression
(Expr
), Rtyp
, CE_Range_Check_Failed
);
7105 Generate_Range_Check
(Expr
, Rtyp
, CE_Range_Check_Failed
);
7108 Set_Do_Range_Check
(Expr
, False);
7111 -- Contiguous non-standard enumeration type
7113 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7115 Unchecked_Convert_To
(Etyp
,
7118 Make_Integer_Literal
(Loc
,
7119 Enumeration_Rep
(First_Literal
(Etyp
))),
7121 Unchecked_Convert_To
(
7123 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
7126 -- Standard enumeration type
7129 Rewrite
(N
, OK_Convert_To
(Typ
, Expr
));
7132 -- Suppress checks since the range check was done above
7133 -- and it guarantees that the addition cannot overflow.
7135 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
7138 -- Deal with integer types
7140 elsif Is_Integer_Type
(Etyp
) then
7141 Rewrite
(N
, Convert_To
(Typ
, Expr
));
7142 Analyze_And_Resolve
(N
, Typ
);
7150 -- The code for valid is dependent on the particular types involved.
7151 -- See separate sections below for the generated code in each case.
7153 when Attribute_Valid
=> Valid
: declare
7154 PBtyp
: Entity_Id
:= Implementation_Base_Type
(Validated_View
(Ptyp
));
7155 pragma Assert
(Is_Scalar_Type
(PBtyp
)
7156 or else Serious_Errors_Detected
> 0);
7158 -- The scalar base type, looking through private types
7160 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
7161 -- Save the validity checking mode. We always turn off validity
7162 -- checking during process of 'Valid since this is one place
7163 -- where we do not want the implicit validity checks to interfere
7164 -- with the explicit validity check that the programmer is doing.
7166 function Make_Range_Test
return Node_Id
;
7167 -- Build the code for a range test of the form
7168 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
7170 ---------------------
7171 -- Make_Range_Test --
7172 ---------------------
7174 function Make_Range_Test
return Node_Id
is
7178 -- The prefix of attribute 'Valid should always denote an object
7179 -- reference. The reference is either coming directly from source
7180 -- or is produced by validity check expansion. The object may be
7181 -- wrapped in a conversion in which case the call to Unqual_Conv
7184 -- If the prefix denotes a variable which captures the value of
7185 -- an object for validation purposes, use the variable in the
7186 -- range test. This ensures that no extra copies or extra reads
7187 -- are produced as part of the test. Generate:
7189 -- Temp : ... := Object;
7190 -- if not Temp in ... then
7192 if Is_Validation_Variable_Reference
(Pref
) then
7193 Temp
:= New_Occurrence_Of
(Entity
(Unqual_Conv
(Pref
)), Loc
);
7195 -- Otherwise the prefix is either a source object or a constant
7196 -- produced by validity check expansion. Generate:
7198 -- Temp : constant ... := Pref;
7199 -- if not Temp in ... then
7202 Temp
:= Duplicate_Subexpr
(Pref
);
7206 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7210 Left_Opnd
=> Unchecked_Convert_To
(PBtyp
, Temp
),
7214 Unchecked_Convert_To
(PBtyp
,
7215 Make_Attribute_Reference
(Loc
,
7217 New_Occurrence_Of
(Val_Typ
, Loc
),
7218 Attribute_Name
=> Name_First
)),
7220 Unchecked_Convert_To
(PBtyp
,
7221 Make_Attribute_Reference
(Loc
,
7223 New_Occurrence_Of
(Val_Typ
, Loc
),
7224 Attribute_Name
=> Name_Last
))));
7226 end Make_Range_Test
;
7232 -- Start of processing for Attribute_Valid
7235 -- Do not expand sourced code 'Valid reference in CodePeer mode,
7236 -- will be handled by the back-end directly.
7238 if CodePeer_Mode
and then Comes_From_Source
(N
) then
7242 -- Turn off validity checks. We do not want any implicit validity
7243 -- checks to intefere with the explicit check from the attribute
7245 Validity_Checks_On
:= False;
7247 -- Floating-point case. This case is handled by the Valid attribute
7248 -- code in the floating-point attribute run-time library.
7250 if Is_Floating_Point_Type
(Ptyp
) then
7251 Float_Valid
: declare
7255 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
7256 -- Return entity for Pkg.Nam
7258 --------------------
7259 -- Get_Fat_Entity --
7260 --------------------
7262 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
7263 Exp_Name
: constant Node_Id
:=
7264 Make_Selected_Component
(Loc
,
7265 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
7266 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
7268 Find_Selected_Component
(Exp_Name
);
7269 return Entity
(Exp_Name
);
7272 -- Start of processing for Float_Valid
7275 -- The C back end handles Valid for floating-point types
7277 if Modify_Tree_For_C
then
7278 Analyze_And_Resolve
(Pref
, Ptyp
);
7279 Set_Etype
(N
, Standard_Boolean
);
7283 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
7285 -- If the prefix is a reverse SSO component, or is possibly
7286 -- unaligned, first create a temporary copy that is in
7287 -- native SSO, and properly aligned. Make it Volatile to
7288 -- prevent folding in the back-end. Note that we use an
7289 -- intermediate constrained string type to initialize the
7290 -- temporary, as the value at hand might be invalid, and in
7291 -- that case it cannot be copied using a floating point
7294 if In_Reverse_Storage_Order_Object
(Pref
)
7295 or else Is_Possibly_Unaligned_Object
(Pref
)
7298 Temp
: constant Entity_Id
:=
7299 Make_Temporary
(Loc
, 'F');
7301 Fat_S
: constant Entity_Id
:=
7302 Get_Fat_Entity
(Name_S
);
7303 -- Constrained string subtype of appropriate size
7305 Fat_P
: constant Entity_Id
:=
7306 Get_Fat_Entity
(Name_P
);
7309 Decl
: constant Node_Id
:=
7310 Make_Object_Declaration
(Loc
,
7311 Defining_Identifier
=> Temp
,
7312 Aliased_Present
=> True,
7313 Object_Definition
=>
7314 New_Occurrence_Of
(Ptyp
, Loc
));
7317 Set_Aspect_Specifications
(Decl
, New_List
(
7318 Make_Aspect_Specification
(Loc
,
7320 Make_Identifier
(Loc
, Name_Volatile
))));
7326 Make_Assignment_Statement
(Loc
,
7328 Make_Explicit_Dereference
(Loc
,
7330 Unchecked_Convert_To
(Fat_P
,
7331 Make_Attribute_Reference
(Loc
,
7333 New_Occurrence_Of
(Temp
, Loc
),
7335 Name_Unrestricted_Access
))),
7337 Unchecked_Convert_To
(Fat_S
,
7338 Relocate_Node
(Pref
)))),
7340 Suppress
=> All_Checks
);
7342 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
7346 -- We now have an object of the proper endianness and
7347 -- alignment, and can construct a Valid attribute.
7349 -- We make sure the prefix of this valid attribute is
7350 -- marked as not coming from source, to avoid losing
7351 -- warnings from 'Valid looking like a possible update.
7353 Set_Comes_From_Source
(Pref
, False);
7355 Expand_Fpt_Attribute
7356 (N
, Pkg
, Name_Valid
,
7358 Make_Attribute_Reference
(Loc
,
7359 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
7360 Attribute_Name
=> Name_Unrestricted_Access
)));
7363 -- One more task, we still need a range check. Required
7364 -- only if we have a constraint, since the Valid routine
7365 -- catches infinities properly (infinities are never valid).
7367 -- The way we do the range check is simply to create the
7368 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
7370 if not Subtypes_Statically_Match
(Ptyp
, PBtyp
) then
7373 Left_Opnd
=> Relocate_Node
(N
),
7376 Left_Opnd
=> Convert_To
(PBtyp
, Pref
),
7377 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
7381 -- Enumeration type with holes
7383 -- For enumeration types with holes, the Pos value constructed by
7384 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
7385 -- second argument of False returns minus one for an invalid value,
7386 -- and the non-negative pos value for a valid value, so the
7387 -- expansion of X'Valid is simply:
7389 -- type(X)'Pos (X) >= 0
7391 -- We can't quite generate it that way because of the requirement
7392 -- for the non-standard second argument of False in the resulting
7393 -- rep_to_pos call, so we have to explicitly create:
7395 -- _rep_to_pos (X, False) >= 0
7397 -- If we have an enumeration subtype, we also check that the
7398 -- value is in range:
7400 -- _rep_to_pos (X, False) >= 0
7402 -- (X >= type(X)'First and then type(X)'Last <= X)
7404 elsif Is_Enumeration_Type
(Ptyp
)
7405 and then Present
(Enum_Pos_To_Rep
(PBtyp
))
7410 Make_Function_Call
(Loc
,
7412 New_Occurrence_Of
(TSS
(PBtyp
, TSS_Rep_To_Pos
), Loc
),
7413 Parameter_Associations
=> New_List
(
7415 New_Occurrence_Of
(Standard_False
, Loc
))),
7416 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
7418 -- Skip the range test for boolean types, as it buys us
7419 -- nothing. The function called above already fails for
7420 -- values different from both True and False.
7422 if Ptyp
/= PBtyp
and then not Is_Boolean_Type
(PBtyp
)
7424 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(PBtyp
)
7426 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(PBtyp
))
7428 -- The call to Make_Range_Test will create declarations
7429 -- that need a proper insertion point, but Pref is now
7430 -- attached to a node with no ancestor. Attach to tree
7431 -- even if it is to be rewritten below.
7433 Set_Parent
(Tst
, Parent
(N
));
7437 Left_Opnd
=> Make_Range_Test
,
7443 -- Fortran convention booleans
7445 -- For the very special case of Fortran convention booleans, the
7446 -- value is always valid, since it is an integer with the semantics
7447 -- that non-zero is true, and any value is permissible.
7449 elsif Is_Boolean_Type
(Ptyp
)
7450 and then Convention
(Ptyp
) = Convention_Fortran
7452 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
7454 -- For biased representations, we will be doing an unchecked
7455 -- conversion without unbiasing the result. That means that the range
7456 -- test has to take this into account, and the proper form of the
7459 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
7461 elsif Has_Biased_Representation
(Ptyp
) then
7462 PBtyp
:= RTE
(RE_Unsigned_32
);
7466 Unchecked_Convert_To
(PBtyp
, Duplicate_Subexpr
(Pref
)),
7468 Unchecked_Convert_To
(PBtyp
,
7469 Make_Attribute_Reference
(Loc
,
7470 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7471 Attribute_Name
=> Name_Range_Length
))));
7473 -- For all other scalar types, what we want logically is a
7476 -- X in type(X)'First .. type(X)'Last
7478 -- But that's precisely what won't work because of possible
7479 -- unwanted optimization (and indeed the basic motivation for
7480 -- the Valid attribute is exactly that this test does not work).
7481 -- What will work is:
7483 -- PBtyp!(X) >= PBtyp!(type(X)'First)
7485 -- PBtyp!(X) <= PBtyp!(type(X)'Last)
7487 -- where PBtyp is an integer type large enough to cover the full
7488 -- range of possible stored values (i.e. it is chosen on the basis
7489 -- of the size of the type, not the range of the values). We write
7490 -- this as two tests, rather than a range check, so that static
7491 -- evaluation will easily remove either or both of the checks if
7492 -- they can be statically determined to be true (this happens
7493 -- when the type of X is static and the range extends to the full
7494 -- range of stored values).
7496 -- Unsigned types. Note: it is safe to consider only whether the
7497 -- subtype is unsigned, since we will in that case be doing all
7498 -- unsigned comparisons based on the subtype range. Since we use the
7499 -- actual subtype object size, this is appropriate.
7501 -- For example, if we have
7503 -- subtype x is integer range 1 .. 200;
7504 -- for x'Object_Size use 8;
7506 -- Now the base type is signed, but objects of this type are bits
7507 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7508 -- correct, even though a value greater than 127 looks signed to a
7509 -- signed comparison.
7513 Uns
: constant Boolean :=
7514 Is_Unsigned_Type
(Ptyp
)
7515 or else (Is_Private_Type
(Ptyp
)
7516 and then Is_Unsigned_Type
(PBtyp
));
7518 P
: Node_Id
:= Pref
;
7521 -- If the prefix is an object, use the Esize from this object
7522 -- to handle in a more user friendly way the case of objects
7523 -- or components with a large Size aspect: if a Size aspect is
7524 -- specified, we want to read a scalar value as large as the
7525 -- Size, unless the Size is larger than
7526 -- System_Max_Integer_Size.
7528 if Nkind
(P
) = N_Selected_Component
then
7529 P
:= Selector_Name
(P
);
7532 if Nkind
(P
) in N_Has_Entity
7533 and then Present
(Entity
(P
))
7534 and then Is_Object
(Entity
(P
))
7535 and then Known_Esize
(Entity
(P
))
7537 if Esize
(Entity
(P
)) <= System_Max_Integer_Size
then
7538 Size
:= Esize
(Entity
(P
));
7540 Size
:= UI_From_Int
(System_Max_Integer_Size
);
7543 Size
:= Esize
(Ptyp
);
7546 PBtyp
:= Small_Integer_Type_For
(Size
, Uns
);
7547 Rewrite
(N
, Make_Range_Test
);
7551 -- If a predicate is present, then we do the predicate test, even if
7552 -- within the predicate function (infinite recursion is warned about
7553 -- in Sem_Attr in that case).
7556 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
7559 if Present
(Pred_Func
) then
7562 Left_Opnd
=> Relocate_Node
(N
),
7563 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
7567 Analyze_And_Resolve
(N
, Standard_Boolean
);
7568 Validity_Checks_On
:= Save_Validity_Checks_On
;
7575 when Attribute_Valid_Value
=>
7576 Exp_Imgv
.Expand_Valid_Value_Attribute
(N
);
7582 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
7583 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7587 -- Assume that the prefix does not need validation
7591 -- Attribute 'Valid_Scalars is not supported on private tagged types;
7592 -- see a detailed explanation where this attribute is analyzed.
7594 if Is_Private_Type
(Ptyp
) and then Is_Tagged_Type
(Ptyp
) then
7597 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7600 elsif not Scalar_Part_Present
(Val_Typ
) then
7603 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7604 -- validated type is a scalar type. Generate:
7606 -- Val_Typ (Pref)'Valid
7608 elsif Is_Scalar_Type
(Val_Typ
) then
7610 Make_Attribute_Reference
(Loc
,
7612 Unchecked_Convert_To
(Val_Typ
, New_Copy_Tree
(Pref
)),
7613 Attribute_Name
=> Name_Valid
);
7615 -- Required by LLVM although the sizes are the same???
7617 if Nkind
(Prefix
(Expr
)) = N_Unchecked_Type_Conversion
then
7618 Set_No_Truncation
(Prefix
(Expr
));
7621 -- Validate the scalar components of an array by iterating over all
7622 -- dimensions of the array while checking individual components.
7624 elsif Is_Array_Type
(Val_Typ
) then
7626 Make_Function_Call
(Loc
,
7629 (Build_Array_VS_Func
7632 Array_Typ
=> Val_Typ
),
7634 Parameter_Associations
=> New_List
(Pref
));
7636 -- Validate the scalar components, discriminants of a record type by
7637 -- examining the structure of a record type.
7639 elsif Is_Record_Type
(Val_Typ
) then
7641 Make_Function_Call
(Loc
,
7644 (Build_Record_VS_Func
7647 Rec_Typ
=> Val_Typ
),
7649 Parameter_Associations
=> New_List
(Pref
));
7652 -- Default the attribute to True when the type of the prefix does not
7656 Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
7660 Analyze_And_Resolve
(N
, Standard_Boolean
);
7661 Set_Is_Static_Expression
(N
, False);
7668 when Attribute_Value
=>
7669 Exp_Imgv
.Expand_Value_Attribute
(N
);
7675 -- The processing for Value_Size shares the processing for Size
7681 -- The processing for Version shares the processing for Body_Version
7687 when Attribute_Wide_Image
=>
7688 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7689 -- back-end knows how to handle this attribute directly.
7691 if CodePeer_Mode
then
7695 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
7697 ---------------------
7698 -- Wide_Wide_Image --
7699 ---------------------
7701 when Attribute_Wide_Wide_Image
=>
7702 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7703 -- back-end knows how to handle this attribute directly.
7705 if CodePeer_Mode
then
7709 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7715 -- We expand typ'Wide_Value (X) into
7718 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7720 -- Wide_String_To_String is a runtime function that converts its wide
7721 -- string argument to String, converting any non-translatable characters
7722 -- into appropriate escape sequences. This preserves the required
7723 -- semantics of Wide_Value in all cases, and results in a very simple
7724 -- implementation approach.
7726 -- Note: for this approach to be fully standard compliant for the cases
7727 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7728 -- method must cover the entire character range (e.g. UTF-8). But that
7729 -- is a reasonable requirement when dealing with encoded character
7730 -- sequences. Presumably if one of the restrictive encoding mechanisms
7731 -- is in use such as Shift-JIS, then characters that cannot be
7732 -- represented using this encoding will not appear in any case.
7734 when Attribute_Wide_Value
=>
7736 Make_Attribute_Reference
(Loc
,
7738 Attribute_Name
=> Name_Value
,
7740 Expressions
=> New_List
(
7741 Make_Function_Call
(Loc
,
7743 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7745 Parameter_Associations
=> New_List
(
7746 Relocate_Node
(First
(Exprs
)),
7747 Make_Integer_Literal
(Loc
,
7748 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7750 Analyze_And_Resolve
(N
, Typ
);
7752 ---------------------
7753 -- Wide_Wide_Value --
7754 ---------------------
7756 -- We expand typ'Wide_Value_Value (X) into
7759 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7761 -- See Wide_Value for more information. This is not quite right where
7762 -- typ = Wide_Wide_Character, because the encoding method may not cover
7763 -- the whole character type.
7765 when Attribute_Wide_Wide_Value
=>
7767 Make_Attribute_Reference
(Loc
,
7769 Attribute_Name
=> Name_Value
,
7771 Expressions
=> New_List
(
7772 Make_Function_Call
(Loc
,
7775 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7777 Parameter_Associations
=> New_List
(
7778 Relocate_Node
(First
(Exprs
)),
7779 Make_Integer_Literal
(Loc
,
7780 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7782 Analyze_And_Resolve
(N
, Typ
);
7784 ---------------------
7785 -- Wide_Wide_Width --
7786 ---------------------
7788 when Attribute_Wide_Wide_Width
=>
7789 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7795 when Attribute_Wide_Width
=>
7796 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7802 when Attribute_Width
=>
7803 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7809 when Attribute_Write
=> Write
: declare
7810 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7811 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7819 -- If no underlying type, we have an error that will be diagnosed
7820 -- elsewhere, so here we just completely ignore the expansion.
7826 -- Stream operations can appear in user code even if the restriction
7827 -- No_Streams is active (for example, when instantiating a predefined
7828 -- container). In that case rewrite the attribute as a Raise to
7829 -- prevent any run-time use.
7831 if Restriction_Active
(No_Streams
) then
7833 Make_Raise_Program_Error
(Sloc
(N
),
7834 Reason
=> PE_Stream_Operation_Not_Allowed
));
7835 Set_Etype
(N
, U_Type
);
7839 -- The simple case, if there is a TSS for Write, just call it
7841 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
7843 if Present
(Pname
) then
7847 -- If there is a Stream_Convert pragma, use it, we rewrite
7849 -- sourcetyp'Output (stream, Item)
7853 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7855 -- where strmwrite is the given Write function that converts an
7856 -- argument of type sourcetyp or a type acctyp, from which it is
7857 -- derived to type strmtyp. The conversion to acttyp is required
7858 -- for the derived case.
7860 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7862 if Present
(Prag
) then
7864 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7865 Wfunc
:= Entity
(Expression
(Arg3
));
7868 Make_Attribute_Reference
(Loc
,
7869 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7870 Attribute_Name
=> Name_Output
,
7871 Expressions
=> New_List
(
7872 Relocate_Node
(First
(Exprs
)),
7873 Make_Function_Call
(Loc
,
7874 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7875 Parameter_Associations
=> New_List
(
7876 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7877 Relocate_Node
(Next
(First
(Exprs
)))))))));
7884 elsif Default_Streaming_Unavailable
(U_Type
) then
7885 -- Do the same thing here as is done above in the
7886 -- case where a No_Streams restriction is active.
7889 Make_Raise_Program_Error
(Sloc
(N
),
7890 Reason
=> PE_Stream_Operation_Not_Allowed
));
7891 Set_Etype
(N
, U_Type
);
7894 -- For elementary types, we call the W_xxx routine directly
7896 elsif Is_Elementary_Type
(U_Type
) then
7897 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7903 elsif Is_Array_Type
(U_Type
) then
7904 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7905 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
7907 -- Tagged type case, use the primitive Write function. Note that
7908 -- this will dispatch in the class-wide case which is what we want
7910 elsif Is_Tagged_Type
(U_Type
) then
7911 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7913 -- All other record type cases, including protected records.
7914 -- The latter only arise for expander generated code for
7915 -- handling shared passive partition access.
7919 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7921 -- Ada 2005 (AI-216): Program_Error is raised when executing
7922 -- the default implementation of the Write attribute of an
7923 -- Unchecked_Union type. However, if the 'Write reference is
7924 -- within the generated Output stream procedure, Write outputs
7925 -- the components, and the default values of the discriminant
7926 -- are streamed by the Output procedure itself. If there are
7927 -- no default values this is also erroneous.
7929 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
7930 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7931 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
7932 or else No
(Discriminant_Default_Value
7933 (First_Discriminant
(U_Type
)))
7936 Make_Raise_Program_Error
(Loc
,
7937 Reason
=> PE_Unchecked_Union_Restriction
));
7938 Set_Etype
(N
, U_Type
);
7943 if Has_Defaulted_Discriminants
(U_Type
) then
7944 Build_Mutable_Record_Write_Procedure
7945 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7947 Build_Record_Write_Procedure
7948 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7951 Insert_Action
(N
, Decl
);
7955 -- If we fall through, Pname is the procedure to be called
7957 Rewrite_Attribute_Proc_Call
(Pname
);
7960 -- The following attributes are handled by the back end (except that
7961 -- static cases have already been evaluated during semantic processing,
7962 -- but in any case the back end should not count on this).
7964 when Attribute_Code_Address
7966 | Attribute_Null_Parameter
7967 | Attribute_Passed_By_Reference
7968 | Attribute_Pool_Address
7972 -- The following attributes should not appear at this stage, since they
7973 -- have already been handled by the analyzer (and properly rewritten
7974 -- with corresponding values or entities to represent the right values).
7976 when Attribute_Abort_Signal
7977 | Attribute_Address_Size
7979 | Attribute_Atomic_Always_Lock_Free
7981 | Attribute_Bit_Order
7983 | Attribute_Compiler_Version
7984 | Attribute_Default_Bit_Order
7985 | Attribute_Default_Scalar_Storage_Order
7986 | Attribute_Definite
7993 | Attribute_Fast_Math
7994 | Attribute_First_Valid
7995 | Attribute_Has_Access_Values
7996 | Attribute_Has_Discriminants
7997 | Attribute_Has_Tagged_Values
7999 | Attribute_Last_Valid
8000 | Attribute_Library_Level
8001 | Attribute_Machine_Emax
8002 | Attribute_Machine_Emin
8003 | Attribute_Machine_Mantissa
8004 | Attribute_Machine_Overflows
8005 | Attribute_Machine_Radix
8006 | Attribute_Machine_Rounds
8007 | Attribute_Max_Alignment_For_Allocation
8008 | Attribute_Max_Integer_Size
8009 | Attribute_Maximum_Alignment
8010 | Attribute_Model_Emin
8011 | Attribute_Model_Epsilon
8012 | Attribute_Model_Mantissa
8013 | Attribute_Model_Small
8015 | Attribute_Partition_ID
8017 | Attribute_Restriction_Set
8018 | Attribute_Safe_Emax
8019 | Attribute_Safe_First
8020 | Attribute_Safe_Large
8021 | Attribute_Safe_Last
8022 | Attribute_Safe_Small
8023 | Attribute_Scalar_Storage_Order
8025 | Attribute_Signed_Zeros
8027 | Attribute_Small_Denominator
8028 | Attribute_Small_Numerator
8029 | Attribute_Storage_Unit
8030 | Attribute_Stub_Type
8031 | Attribute_System_Allocator_Alignment
8032 | Attribute_Target_Name
8033 | Attribute_Type_Class
8034 | Attribute_Type_Key
8035 | Attribute_Unconstrained_Array
8036 | Attribute_Universal_Literal_String
8037 | Attribute_Wchar_T_Size
8038 | Attribute_Word_Size
8040 raise Program_Error
;
8043 -- Note: as mentioned earlier, individual sections of the above case
8044 -- statement assume there is no code after the case statement, and are
8045 -- legitimately allowed to execute return statements if they have nothing
8046 -- more to do, so DO NOT add code at this point.
8049 when RE_Not_Available
=>
8051 end Expand_N_Attribute_Reference
;
8053 --------------------------------
8054 -- Expand_Pred_Succ_Attribute --
8055 --------------------------------
8057 -- For typ'Pred (exp), we generate the check
8059 -- [constraint_error when exp = typ'Base'First]
8061 -- Similarly, for typ'Succ (exp), we generate the check
8063 -- [constraint_error when exp = typ'Base'Last]
8065 -- These checks are not generated for modular types, since the proper
8066 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
8067 -- We also suppress these checks if we are the right side of an assignment
8068 -- statement or the expression of an object declaration, where the flag
8069 -- Suppress_Assignment_Checks is set for the assignment/declaration.
8071 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
8072 Loc
: constant Source_Ptr
:= Sloc
(N
);
8073 P
: constant Node_Id
:= Parent
(N
);
8077 if Attribute_Name
(N
) = Name_Pred
then
8083 if Nkind
(P
) not in N_Assignment_Statement | N_Object_Declaration
8084 or else not Suppress_Assignment_Checks
(P
)
8087 Make_Raise_Constraint_Error
(Loc
,
8091 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
8093 Make_Attribute_Reference
(Loc
,
8095 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
8096 Attribute_Name
=> Cnam
)),
8097 Reason
=> CE_Overflow_Check_Failed
));
8099 end Expand_Pred_Succ_Attribute
;
8101 ---------------------------
8102 -- Expand_Size_Attribute --
8103 ---------------------------
8105 procedure Expand_Size_Attribute
(N
: Node_Id
) is
8106 Loc
: constant Source_Ptr
:= Sloc
(N
);
8107 Typ
: constant Entity_Id
:= Etype
(N
);
8108 Pref
: constant Node_Id
:= Prefix
(N
);
8109 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
8110 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8114 -- Case of known RM_Size of a type
8116 if Id
in Attribute_Size | Attribute_Value_Size
8117 and then Is_Entity_Name
(Pref
)
8118 and then Is_Type
(Entity
(Pref
))
8119 and then Known_Static_RM_Size
(Entity
(Pref
))
8121 Siz
:= RM_Size
(Entity
(Pref
));
8123 -- Case of known Esize of a type
8125 elsif Id
= Attribute_Object_Size
8126 and then Is_Entity_Name
(Pref
)
8127 and then Is_Type
(Entity
(Pref
))
8128 and then Known_Static_Esize
(Entity
(Pref
))
8130 Siz
:= Esize
(Entity
(Pref
));
8132 -- Case of known size of object
8134 elsif Id
= Attribute_Size
8135 and then Is_Entity_Name
(Pref
)
8136 and then Is_Object
(Entity
(Pref
))
8137 and then Known_Static_Esize
(Entity
(Pref
))
8139 Siz
:= Esize
(Entity
(Pref
));
8141 -- For an array component, we can do Size in the front end if the
8142 -- component_size of the array is set.
8144 elsif Nkind
(Pref
) = N_Indexed_Component
then
8145 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
8147 -- For a record component, we can do Size in the front end if there is a
8148 -- component clause, or if the record is packed and the component's size
8149 -- is known at compile time.
8151 elsif Nkind
(Pref
) = N_Selected_Component
then
8153 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
8154 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
8157 if Present
(Component_Clause
(Comp
)) then
8158 Siz
:= Esize
(Comp
);
8160 elsif Is_Packed
(Rec
) then
8161 Siz
:= RM_Size
(Ptyp
);
8164 Apply_Universal_Integer_Attribute_Checks
(N
);
8169 -- All other cases are handled by the back end
8172 -- If Size is applied to a formal parameter that is of a packed
8173 -- array subtype, then apply Size to the actual subtype.
8175 if Is_Entity_Name
(Pref
)
8176 and then Is_Formal
(Entity
(Pref
))
8177 and then Is_Packed_Array
(Ptyp
)
8180 Make_Attribute_Reference
(Loc
,
8182 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
8183 Attribute_Name
=> Name_Size
));
8184 Analyze_And_Resolve
(N
, Typ
);
8186 -- If Size is applied to a dereference of an access to unconstrained
8187 -- packed array, the back end needs to see its unconstrained nominal
8188 -- type, but also a hint to the actual constrained type.
8190 elsif Nkind
(Pref
) = N_Explicit_Dereference
8191 and then Is_Packed_Array
(Ptyp
)
8192 and then not Is_Constrained
(Ptyp
)
8194 Set_Actual_Designated_Subtype
(Pref
, Get_Actual_Subtype
(Pref
));
8196 -- If Size was applied to a slice of a bit-packed array, we rewrite
8197 -- it into the product of Length and Component_Size. We need to do so
8198 -- because bit-packed arrays are represented internally as arrays of
8199 -- System.Unsigned_Types.Packed_Byte for code generation purposes so
8200 -- the size is always rounded up in the back end.
8202 elsif Nkind
(Pref
) = N_Slice
and then Is_Bit_Packed_Array
(Ptyp
) then
8204 Make_Op_Multiply
(Loc
,
8205 Make_Attribute_Reference
(Loc
,
8206 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8207 Attribute_Name
=> Name_Length
),
8208 Make_Attribute_Reference
(Loc
,
8209 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8210 Attribute_Name
=> Name_Component_Size
)));
8211 Analyze_And_Resolve
(N
, Typ
);
8214 -- Apply the required checks last, after rewriting has taken place
8216 Apply_Universal_Integer_Attribute_Checks
(N
);
8220 -- Common processing for record and array component case
8222 if Present
(Siz
) and then Siz
/= 0 then
8224 CS
: constant Boolean := Comes_From_Source
(N
);
8227 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
8229 -- This integer literal is not a static expression. We do not
8230 -- call Analyze_And_Resolve here, because this would activate
8231 -- the circuit for deciding that a static value was out of range,
8232 -- and we don't want that.
8234 -- So just manually set the type, mark the expression as
8235 -- nonstatic, and then ensure that the result is checked
8236 -- properly if the attribute comes from source (if it was
8237 -- internally generated, we never need a constraint check).
8240 Set_Is_Static_Expression
(N
, False);
8243 Apply_Constraint_Check
(N
, Typ
);
8247 end Expand_Size_Attribute
;
8249 -----------------------------
8250 -- Expand_Update_Attribute --
8251 -----------------------------
8253 procedure Expand_Update_Attribute
(N
: Node_Id
) is
8254 procedure Process_Component_Or_Element_Update
8259 -- Generate the statements necessary to update a single component or an
8260 -- element of the prefix. The code is inserted before the attribute N.
8261 -- Temp denotes the entity of the anonymous object created to reflect
8262 -- the changes in values. Comp is the component/index expression to be
8263 -- updated. Expr is an expression yielding the new value of Comp. Typ
8264 -- is the type of the prefix of attribute Update.
8266 procedure Process_Range_Update
8271 -- Generate the statements necessary to update a slice of the prefix.
8272 -- The code is inserted before the attribute N. Temp denotes the entity
8273 -- of the anonymous object created to reflect the changes in values.
8274 -- Comp is range of the slice to be updated. Expr is an expression
8275 -- yielding the new value of Comp. Typ is the type of the prefix of
8276 -- attribute Update.
8278 -----------------------------------------
8279 -- Process_Component_Or_Element_Update --
8280 -----------------------------------------
8282 procedure Process_Component_Or_Element_Update
8288 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8293 -- An array element may be modified by the following relations
8294 -- depending on the number of dimensions:
8296 -- 1 => Expr -- one dimensional update
8297 -- (1, ..., N) => Expr -- multi dimensional update
8299 -- The above forms are converted in assignment statements where the
8300 -- left hand side is an indexed component:
8302 -- Temp (1) := Expr; -- one dimensional update
8303 -- Temp (1, ..., N) := Expr; -- multi dimensional update
8305 if Is_Array_Type
(Typ
) then
8307 -- The index expressions of a multi dimensional array update
8308 -- appear as an aggregate.
8310 if Nkind
(Comp
) = N_Aggregate
then
8311 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
8313 Exprs
:= New_List
(Relocate_Node
(Comp
));
8317 Make_Indexed_Component
(Loc
,
8318 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8319 Expressions
=> Exprs
);
8321 -- A record component update appears in the following form:
8325 -- The above relation is transformed into an assignment statement
8326 -- where the left hand side is a selected component:
8328 -- Temp.Comp := Expr;
8330 else pragma Assert
(Is_Record_Type
(Typ
));
8332 Make_Selected_Component
(Loc
,
8333 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8334 Selector_Name
=> Relocate_Node
(Comp
));
8338 Make_Assignment_Statement
(Loc
,
8340 Expression
=> Relocate_Node
(Expr
)));
8341 end Process_Component_Or_Element_Update
;
8343 --------------------------
8344 -- Process_Range_Update --
8345 --------------------------
8347 procedure Process_Range_Update
8353 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
8354 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8358 -- A range update appears as
8360 -- (Low .. High => Expr)
8362 -- The above construct is transformed into a loop that iterates over
8363 -- the given range and modifies the corresponding array values to the
8366 -- for Index in Low .. High loop
8367 -- Temp (<Index_Typ> (Index)) := Expr;
8370 Index
:= Make_Temporary
(Loc
, 'I');
8373 Make_Loop_Statement
(Loc
,
8375 Make_Iteration_Scheme
(Loc
,
8376 Loop_Parameter_Specification
=>
8377 Make_Loop_Parameter_Specification
(Loc
,
8378 Defining_Identifier
=> Index
,
8379 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
8381 Statements
=> New_List
(
8382 Make_Assignment_Statement
(Loc
,
8384 Make_Indexed_Component
(Loc
,
8385 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8386 Expressions
=> New_List
(
8387 Convert_To
(Index_Typ
,
8388 New_Occurrence_Of
(Index
, Loc
)))),
8389 Expression
=> Relocate_Node
(Expr
))),
8391 End_Label
=> Empty
));
8392 end Process_Range_Update
;
8396 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
8397 Loc
: constant Source_Ptr
:= Sloc
(N
);
8398 Pref
: constant Node_Id
:= Prefix
(N
);
8399 Typ
: constant Entity_Id
:= Etype
(Pref
);
8402 CW_Temp
: Entity_Id
;
8407 -- Start of processing for Expand_Update_Attribute
8410 -- Create the anonymous object to store the value of the prefix and
8411 -- capture subsequent changes in value.
8413 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
8415 -- Preserve the tag of the prefix by offering a specific view of the
8416 -- class-wide version of the prefix.
8418 if Is_Tagged_Type
(Typ
) then
8421 -- CW_Temp : Typ'Class := Typ'Class (Pref);
8423 CW_Temp
:= Make_Temporary
(Loc
, 'T');
8424 CW_Typ
:= Class_Wide_Type
(Typ
);
8427 Make_Object_Declaration
(Loc
,
8428 Defining_Identifier
=> CW_Temp
,
8429 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
8431 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
8434 -- Temp : Typ renames Typ (CW_Temp);
8437 Make_Object_Renaming_Declaration
(Loc
,
8438 Defining_Identifier
=> Temp
,
8439 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
8441 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
8447 -- Temp : Typ := Pref;
8450 Make_Object_Declaration
(Loc
,
8451 Defining_Identifier
=> Temp
,
8452 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8453 Expression
=> Relocate_Node
(Pref
)));
8456 -- Process the update aggregate
8458 Assoc
:= First
(Component_Associations
(Aggr
));
8459 while Present
(Assoc
) loop
8460 Comp
:= First
(Choices
(Assoc
));
8461 Expr
:= Expression
(Assoc
);
8462 while Present
(Comp
) loop
8463 if Nkind
(Comp
) = N_Range
then
8464 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
8465 elsif Nkind
(Comp
) = N_Subtype_Indication
then
8466 Process_Range_Update
8467 (Temp
, Range_Expression
(Constraint
(Comp
)), Expr
, Typ
);
8469 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
8478 -- The attribute is replaced by a reference to the anonymous object
8480 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8482 end Expand_Update_Attribute
;
8488 procedure Find_Fat_Info
8490 Fat_Type
: out Entity_Id
;
8491 Fat_Pkg
: out RE_Id
)
8493 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
8496 -- All we do is use the root type (historically this dealt with
8497 -- VAX-float .. to be cleaned up further later ???)
8499 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8500 Fat_Type
:= Standard_Float
;
8501 Fat_Pkg
:= RE_Attr_Float
;
8503 elsif Rtyp
= Standard_Long_Float
then
8504 Fat_Type
:= Standard_Long_Float
;
8505 Fat_Pkg
:= RE_Attr_Long_Float
;
8507 elsif Rtyp
= Standard_Long_Long_Float
then
8508 Fat_Type
:= Standard_Long_Long_Float
;
8509 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8511 -- Universal real (which is its own root type) is treated as being
8512 -- equivalent to Standard.Long_Long_Float, since it is defined to
8513 -- have the same precision as the longest Float type.
8515 elsif Rtyp
= Universal_Real
then
8516 Fat_Type
:= Standard_Long_Long_Float
;
8517 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8520 raise Program_Error
;
8524 ----------------------------
8525 -- Find_Stream_Subprogram --
8526 ----------------------------
8528 function Find_Stream_Subprogram
8530 Nam
: TSS_Name_Type
) return Entity_Id
8532 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8533 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
8535 if Present
(Ent
) then
8539 -- Stream attributes for strings are expanded into library calls. The
8540 -- following checks are disabled when the run-time is not available or
8541 -- when compiling predefined types due to bootstrap issues. As a result,
8542 -- the compiler will generate in-place stream routines for string types
8543 -- that appear in GNAT's library, but will generate calls via rtsfind
8544 -- to library routines for user code.
8546 -- Note: In the case of using a configurable run time, it is very likely
8547 -- that stream routines for string types are not present (they require
8548 -- file system support). In this case, the specific stream routines for
8549 -- strings are not used, relying on the regular stream mechanism
8550 -- instead. That is why we include the test RTE_Available when dealing
8551 -- with these cases.
8553 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
8554 -- Storage_Array as defined in package System.Storage_Elements
8556 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
8558 -- Case of No_Stream_Optimizations restriction active
8560 if Restriction_Active
(No_Stream_Optimizations
) then
8561 if Nam
= TSS_Stream_Input
8562 and then RTE_Available
(RE_Storage_Array_Input
)
8564 return RTE
(RE_Storage_Array_Input
);
8566 elsif Nam
= TSS_Stream_Output
8567 and then RTE_Available
(RE_Storage_Array_Output
)
8569 return RTE
(RE_Storage_Array_Output
);
8571 elsif Nam
= TSS_Stream_Read
8572 and then RTE_Available
(RE_Storage_Array_Read
)
8574 return RTE
(RE_Storage_Array_Read
);
8576 elsif Nam
= TSS_Stream_Write
8577 and then RTE_Available
(RE_Storage_Array_Write
)
8579 return RTE
(RE_Storage_Array_Write
);
8581 elsif Nam
/= TSS_Stream_Input
and then
8582 Nam
/= TSS_Stream_Output
and then
8583 Nam
/= TSS_Stream_Read
and then
8584 Nam
/= TSS_Stream_Write
8586 raise Program_Error
;
8589 -- Restriction No_Stream_Optimizations is not set, so we can go
8590 -- ahead and optimize using the block IO forms of the routines.
8593 if Nam
= TSS_Stream_Input
8594 and then RTE_Available
(RE_Storage_Array_Input_Blk_IO
)
8596 return RTE
(RE_Storage_Array_Input_Blk_IO
);
8598 elsif Nam
= TSS_Stream_Output
8599 and then RTE_Available
(RE_Storage_Array_Output_Blk_IO
)
8601 return RTE
(RE_Storage_Array_Output_Blk_IO
);
8603 elsif Nam
= TSS_Stream_Read
8604 and then RTE_Available
(RE_Storage_Array_Read_Blk_IO
)
8606 return RTE
(RE_Storage_Array_Read_Blk_IO
);
8608 elsif Nam
= TSS_Stream_Write
8609 and then RTE_Available
(RE_Storage_Array_Write_Blk_IO
)
8611 return RTE
(RE_Storage_Array_Write_Blk_IO
);
8613 elsif Nam
/= TSS_Stream_Input
and then
8614 Nam
/= TSS_Stream_Output
and then
8615 Nam
/= TSS_Stream_Read
and then
8616 Nam
/= TSS_Stream_Write
8618 raise Program_Error
;
8622 -- Stream_Element_Array as defined in package Ada.Streams
8624 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
8626 -- Case of No_Stream_Optimizations restriction active
8628 if Restriction_Active
(No_Stream_Optimizations
) then
8629 if Nam
= TSS_Stream_Input
8630 and then RTE_Available
(RE_Stream_Element_Array_Input
)
8632 return RTE
(RE_Stream_Element_Array_Input
);
8634 elsif Nam
= TSS_Stream_Output
8635 and then RTE_Available
(RE_Stream_Element_Array_Output
)
8637 return RTE
(RE_Stream_Element_Array_Output
);
8639 elsif Nam
= TSS_Stream_Read
8640 and then RTE_Available
(RE_Stream_Element_Array_Read
)
8642 return RTE
(RE_Stream_Element_Array_Read
);
8644 elsif Nam
= TSS_Stream_Write
8645 and then RTE_Available
(RE_Stream_Element_Array_Write
)
8647 return RTE
(RE_Stream_Element_Array_Write
);
8649 elsif Nam
/= TSS_Stream_Input
and then
8650 Nam
/= TSS_Stream_Output
and then
8651 Nam
/= TSS_Stream_Read
and then
8652 Nam
/= TSS_Stream_Write
8654 raise Program_Error
;
8657 -- Restriction No_Stream_Optimizations is not set, so we can go
8658 -- ahead and optimize using the block IO forms of the routines.
8661 if Nam
= TSS_Stream_Input
8662 and then RTE_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
8664 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
8666 elsif Nam
= TSS_Stream_Output
8667 and then RTE_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
8669 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
8671 elsif Nam
= TSS_Stream_Read
8672 and then RTE_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
8674 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
8676 elsif Nam
= TSS_Stream_Write
8677 and then RTE_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
8679 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
8681 elsif Nam
/= TSS_Stream_Input
and then
8682 Nam
/= TSS_Stream_Output
and then
8683 Nam
/= TSS_Stream_Read
and then
8684 Nam
/= TSS_Stream_Write
8686 raise Program_Error
;
8690 -- String as defined in package Ada
8692 elsif Base_Typ
= Standard_String
then
8694 -- Case of No_Stream_Optimizations restriction active
8696 if Restriction_Active
(No_Stream_Optimizations
) then
8697 if Nam
= TSS_Stream_Input
8698 and then RTE_Available
(RE_String_Input
)
8700 return RTE
(RE_String_Input
);
8702 elsif Nam
= TSS_Stream_Output
8703 and then RTE_Available
(RE_String_Output
)
8705 return RTE
(RE_String_Output
);
8707 elsif Nam
= TSS_Stream_Read
8708 and then RTE_Available
(RE_String_Read
)
8710 return RTE
(RE_String_Read
);
8712 elsif Nam
= TSS_Stream_Write
8713 and then RTE_Available
(RE_String_Write
)
8715 return RTE
(RE_String_Write
);
8717 elsif Nam
/= TSS_Stream_Input
and then
8718 Nam
/= TSS_Stream_Output
and then
8719 Nam
/= TSS_Stream_Read
and then
8720 Nam
/= TSS_Stream_Write
8722 raise Program_Error
;
8725 -- Restriction No_Stream_Optimizations is not set, so we can go
8726 -- ahead and optimize using the block IO forms of the routines.
8729 if Nam
= TSS_Stream_Input
8730 and then RTE_Available
(RE_String_Input_Blk_IO
)
8732 return RTE
(RE_String_Input_Blk_IO
);
8734 elsif Nam
= TSS_Stream_Output
8735 and then RTE_Available
(RE_String_Output_Blk_IO
)
8737 return RTE
(RE_String_Output_Blk_IO
);
8739 elsif Nam
= TSS_Stream_Read
8740 and then RTE_Available
(RE_String_Read_Blk_IO
)
8742 return RTE
(RE_String_Read_Blk_IO
);
8744 elsif Nam
= TSS_Stream_Write
8745 and then RTE_Available
(RE_String_Write_Blk_IO
)
8747 return RTE
(RE_String_Write_Blk_IO
);
8749 elsif Nam
/= TSS_Stream_Input
and then
8750 Nam
/= TSS_Stream_Output
and then
8751 Nam
/= TSS_Stream_Read
and then
8752 Nam
/= TSS_Stream_Write
8754 raise Program_Error
;
8758 -- Wide_String as defined in package Ada
8760 elsif Base_Typ
= Standard_Wide_String
then
8762 -- Case of No_Stream_Optimizations restriction active
8764 if Restriction_Active
(No_Stream_Optimizations
) then
8765 if Nam
= TSS_Stream_Input
8766 and then RTE_Available
(RE_Wide_String_Input
)
8768 return RTE
(RE_Wide_String_Input
);
8770 elsif Nam
= TSS_Stream_Output
8771 and then RTE_Available
(RE_Wide_String_Output
)
8773 return RTE
(RE_Wide_String_Output
);
8775 elsif Nam
= TSS_Stream_Read
8776 and then RTE_Available
(RE_Wide_String_Read
)
8778 return RTE
(RE_Wide_String_Read
);
8780 elsif Nam
= TSS_Stream_Write
8781 and then RTE_Available
(RE_Wide_String_Write
)
8783 return RTE
(RE_Wide_String_Write
);
8785 elsif Nam
/= TSS_Stream_Input
and then
8786 Nam
/= TSS_Stream_Output
and then
8787 Nam
/= TSS_Stream_Read
and then
8788 Nam
/= TSS_Stream_Write
8790 raise Program_Error
;
8793 -- Restriction No_Stream_Optimizations is not set, so we can go
8794 -- ahead and optimize using the block IO forms of the routines.
8797 if Nam
= TSS_Stream_Input
8798 and then RTE_Available
(RE_Wide_String_Input_Blk_IO
)
8800 return RTE
(RE_Wide_String_Input_Blk_IO
);
8802 elsif Nam
= TSS_Stream_Output
8803 and then RTE_Available
(RE_Wide_String_Output_Blk_IO
)
8805 return RTE
(RE_Wide_String_Output_Blk_IO
);
8807 elsif Nam
= TSS_Stream_Read
8808 and then RTE_Available
(RE_Wide_String_Read_Blk_IO
)
8810 return RTE
(RE_Wide_String_Read_Blk_IO
);
8812 elsif Nam
= TSS_Stream_Write
8813 and then RTE_Available
(RE_Wide_String_Write_Blk_IO
)
8815 return RTE
(RE_Wide_String_Write_Blk_IO
);
8817 elsif Nam
/= TSS_Stream_Input
and then
8818 Nam
/= TSS_Stream_Output
and then
8819 Nam
/= TSS_Stream_Read
and then
8820 Nam
/= TSS_Stream_Write
8822 raise Program_Error
;
8826 -- Wide_Wide_String as defined in package Ada
8828 elsif Base_Typ
= Standard_Wide_Wide_String
then
8830 -- Case of No_Stream_Optimizations restriction active
8832 if Restriction_Active
(No_Stream_Optimizations
) then
8833 if Nam
= TSS_Stream_Input
8834 and then RTE_Available
(RE_Wide_Wide_String_Input
)
8836 return RTE
(RE_Wide_Wide_String_Input
);
8838 elsif Nam
= TSS_Stream_Output
8839 and then RTE_Available
(RE_Wide_Wide_String_Output
)
8841 return RTE
(RE_Wide_Wide_String_Output
);
8843 elsif Nam
= TSS_Stream_Read
8844 and then RTE_Available
(RE_Wide_Wide_String_Read
)
8846 return RTE
(RE_Wide_Wide_String_Read
);
8848 elsif Nam
= TSS_Stream_Write
8849 and then RTE_Available
(RE_Wide_Wide_String_Write
)
8851 return RTE
(RE_Wide_Wide_String_Write
);
8853 elsif Nam
/= TSS_Stream_Input
and then
8854 Nam
/= TSS_Stream_Output
and then
8855 Nam
/= TSS_Stream_Read
and then
8856 Nam
/= TSS_Stream_Write
8858 raise Program_Error
;
8861 -- Restriction No_Stream_Optimizations is not set, so we can go
8862 -- ahead and optimize using the block IO forms of the routines.
8865 if Nam
= TSS_Stream_Input
8866 and then RTE_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
8868 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
8870 elsif Nam
= TSS_Stream_Output
8871 and then RTE_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
8873 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
8875 elsif Nam
= TSS_Stream_Read
8876 and then RTE_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
8878 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
8880 elsif Nam
= TSS_Stream_Write
8881 and then RTE_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
8883 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
8885 elsif Nam
/= TSS_Stream_Input
and then
8886 Nam
/= TSS_Stream_Output
and then
8887 Nam
/= TSS_Stream_Read
and then
8888 Nam
/= TSS_Stream_Write
8890 raise Program_Error
;
8896 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
8897 return Find_Prim_Op
(Typ
, Nam
);
8899 return Find_Inherited_TSS
(Typ
, Nam
);
8901 end Find_Stream_Subprogram
;
8907 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
8911 BT
:= Base_Type
(T
);
8913 if Is_Private_Type
(BT
)
8914 and then Present
(Full_View
(BT
))
8916 BT
:= Full_View
(BT
);
8922 -------------------------------
8923 -- Get_Stream_Convert_Pragma --
8924 -------------------------------
8926 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
8931 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8932 -- that a stream convert pragma for a tagged type is not inherited from
8933 -- its parent. Probably what is wrong here is that it is basically
8934 -- incorrect to consider a stream convert pragma to be a representation
8935 -- pragma at all ???
8937 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
8938 while Present
(N
) loop
8939 if Nkind
(N
) = N_Pragma
8940 and then Pragma_Name
(N
) = Name_Stream_Convert
8942 -- For tagged types this pragma is not inherited, so we
8943 -- must verify that it is defined for the given type and
8947 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
8949 if not Is_Tagged_Type
(T
)
8951 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8961 end Get_Stream_Convert_Pragma
;
8963 ---------------------------------
8964 -- Is_Constrained_Packed_Array --
8965 ---------------------------------
8967 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8968 Arr
: Entity_Id
:= Typ
;
8971 if Is_Access_Type
(Arr
) then
8972 Arr
:= Designated_Type
(Arr
);
8975 return Is_Array_Type
(Arr
)
8976 and then Is_Constrained
(Arr
)
8977 and then Present
(Packed_Array_Impl_Type
(Arr
));
8978 end Is_Constrained_Packed_Array
;
8980 ----------------------------------------
8981 -- Is_Inline_Floating_Point_Attribute --
8982 ----------------------------------------
8984 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8985 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8987 function Is_GCC_Target
return Boolean;
8988 -- Return True if we are using a GCC target/back-end
8989 -- ??? Note: the implementation is kludgy/fragile
8995 function Is_GCC_Target
return Boolean is
8997 return not CodePeer_Mode
8998 and then not Modify_Tree_For_C
;
9001 -- Start of processing for Is_Inline_Floating_Point_Attribute
9004 -- Machine and Model can be expanded by the GCC back end only
9006 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
9007 return Is_GCC_Target
;
9009 -- Remaining cases handled by all back ends are Rounding and Truncation
9010 -- when appearing as the operand of a conversion to some integer type.
9012 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
9013 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
9018 -- Here we are in the integer conversion context. We reuse Rounding for
9019 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
9022 Id
= Attribute_Rounding
9023 or else Id
= Attribute_Machine_Rounding
9024 or else Id
= Attribute_Truncation
;
9025 end Is_Inline_Floating_Point_Attribute
;