1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Exp_Atag
; use Exp_Atag
;
32 with Exp_Ch2
; use Exp_Ch2
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Dist
; use Exp_Dist
;
37 with Exp_Imgv
; use Exp_Imgv
;
38 with Exp_Pakd
; use Exp_Pakd
;
39 with Exp_Strm
; use Exp_Strm
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Fname
; use Fname
;
43 with Freeze
; use Freeze
;
44 with Gnatvsn
; use Gnatvsn
;
45 with Itypes
; use Itypes
;
47 with Namet
; use Namet
;
48 with Nmake
; use Nmake
;
49 with Nlists
; use Nlists
;
51 with Restrict
; use Restrict
;
52 with Rident
; use Rident
;
53 with Rtsfind
; use Rtsfind
;
55 with Sem_Aux
; use Sem_Aux
;
56 with Sem_Ch6
; use Sem_Ch6
;
57 with Sem_Ch7
; use Sem_Ch7
;
58 with Sem_Ch8
; use Sem_Ch8
;
59 with Sem_Eval
; use Sem_Eval
;
60 with Sem_Res
; use Sem_Res
;
61 with Sem_Util
; use Sem_Util
;
62 with Sinfo
; use Sinfo
;
63 with Snames
; use Snames
;
64 with Stand
; use Stand
;
65 with Stringt
; use Stringt
;
66 with Targparm
; use Targparm
;
67 with Tbuild
; use Tbuild
;
68 with Ttypes
; use Ttypes
;
69 with Uintp
; use Uintp
;
70 with Uname
; use Uname
;
71 with Validsw
; use Validsw
;
73 package body Exp_Attr
is
75 -----------------------
76 -- Local Subprograms --
77 -----------------------
79 function Build_Array_VS_Func
81 Nod
: Node_Id
) return Entity_Id
;
82 -- Build function to test Valid_Scalars for array type A_Type. Nod is the
83 -- Valid_Scalars attribute node, used to insert the function body, and the
84 -- value returned is the entity of the constructed function body. We do not
85 -- bother to generate a separate spec for this subprogram.
87 function Build_Record_VS_Func
89 Nod
: Node_Id
) return Entity_Id
;
90 -- Build function to test Valid_Scalars for record type A_Type. Nod is the
91 -- Valid_Scalars attribute node, used to insert the function body, and the
92 -- value returned is the entity of the constructed function body. We do not
93 -- bother to generate a separate spec for this subprogram.
95 procedure Compile_Stream_Body_In_Scope
100 -- The body for a stream subprogram may be generated outside of the scope
101 -- of the type. If the type is fully private, it may depend on the full
102 -- view of other types (e.g. indexes) that are currently private as well.
103 -- We install the declarations of the package in which the type is declared
104 -- before compiling the body in what is its proper environment. The Check
105 -- parameter indicates if checks are to be suppressed for the stream body.
106 -- We suppress checks for array/record reads, since the rule is that these
107 -- are like assignments, out of range values due to uninitialized storage,
108 -- or other invalid values do NOT cause a Constraint_Error to be raised.
109 -- If we are within an instance body all visibility has been established
110 -- already and there is no need to install the package.
112 procedure Expand_Access_To_Protected_Op
116 -- An attribute reference to a protected subprogram is transformed into
117 -- a pair of pointers: one to the object, and one to the operations.
118 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
120 procedure Expand_Fpt_Attribute
125 -- This procedure expands a call to a floating-point attribute function.
126 -- N is the attribute reference node, and Args is a list of arguments to
127 -- be passed to the function call. Pkg identifies the package containing
128 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
129 -- have already been converted to the floating-point type for which Pkg was
130 -- instantiated. The Nam argument is the relevant attribute processing
131 -- routine to be called. This is the same as the attribute name, except in
132 -- the Unaligned_Valid case.
134 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
135 -- This procedure expands a call to a floating-point attribute function
136 -- that takes a single floating-point argument. The function to be called
137 -- is always the same as the attribute name.
139 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
140 -- This procedure expands a call to a floating-point attribute function
141 -- that takes one floating-point argument and one integer argument. The
142 -- function to be called is always the same as the attribute name.
144 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
145 -- This procedure expands a call to a floating-point attribute function
146 -- that takes two floating-point arguments. The function to be called
147 -- is always the same as the attribute name.
149 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
150 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
151 -- loop may be converted into a conditional block. See body for details.
153 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
154 -- Handle the expansion of attributes 'Max and 'Min, including expanding
155 -- then out if we are in Modify_Tree_For_C mode.
157 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
158 -- Handles expansion of Pred or Succ attributes for case of non-real
159 -- operand with overflow checking required.
161 procedure Expand_Update_Attribute
(N
: Node_Id
);
162 -- Handle the expansion of attribute Update
164 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
165 -- Used for Last, Last, and Length, when the prefix is an array type.
166 -- Obtains the corresponding index subtype.
168 procedure Find_Fat_Info
170 Fat_Type
: out Entity_Id
;
171 Fat_Pkg
: out RE_Id
);
172 -- Given a floating-point type T, identifies the package containing the
173 -- attributes for this type (returned in Fat_Pkg), and the corresponding
174 -- type for which this package was instantiated from Fat_Gen. Error if T
175 -- is not a floating-point type.
177 function Find_Stream_Subprogram
179 Nam
: TSS_Name_Type
) return Entity_Id
;
180 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
181 -- types, the corresponding primitive operation is looked up, else the
182 -- appropriate TSS from the type itself, or from its closest ancestor
183 -- defining it, is returned. In both cases, inheritance of representation
184 -- aspects is thus taken into account.
186 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
187 -- The stream functions need to examine the underlying representation of
188 -- composite types. In some cases T may be non-private but its base type
189 -- is, in which case the function returns the corresponding full view.
191 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
192 -- Given a type, find a corresponding stream convert pragma that applies to
193 -- the implementation base type of this type (Typ). If found, return the
194 -- pragma node, otherwise return Empty if no pragma is found.
196 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
197 -- Utility for array attributes, returns true on packed constrained
198 -- arrays, and on access to same.
200 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
201 -- Returns true iff the given node refers to an attribute call that
202 -- can be expanded directly by the back end and does not need front end
203 -- expansion. Typically used for rounding and truncation attributes that
204 -- appear directly inside a conversion to integer.
206 -------------------------
207 -- Build_Array_VS_Func --
208 -------------------------
210 function Build_Array_VS_Func
212 Nod
: Node_Id
) return Entity_Id
214 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
215 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
216 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
217 Body_Stmts
: List_Id
;
218 Index_List
: List_Id
;
221 function Test_Component
return List_Id
;
222 -- Create one statement to test validity of one component designated by
223 -- a full set of indexes. Returns statement list containing test.
225 function Test_One_Dimension
(N
: Int
) return List_Id
;
226 -- Create loop to test one dimension of the array. The single statement
227 -- in the loop body tests the inner dimensions if any, or else the
228 -- single component. Note that this procedure is called recursively,
229 -- with N being the dimension to be initialized. A call with N greater
230 -- than the number of dimensions simply generates the component test,
231 -- terminating the recursion. Returns statement list containing tests.
237 function Test_Component
return List_Id
is
243 Make_Indexed_Component
(Loc
,
244 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
245 Expressions
=> Index_List
);
247 if Is_Scalar_Type
(Comp_Type
) then
250 Anam
:= Name_Valid_Scalars
;
254 Make_If_Statement
(Loc
,
258 Make_Attribute_Reference
(Loc
,
259 Attribute_Name
=> Anam
,
261 Then_Statements
=> New_List
(
262 Make_Simple_Return_Statement
(Loc
,
263 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
266 ------------------------
267 -- Test_One_Dimension --
268 ------------------------
270 function Test_One_Dimension
(N
: Int
) return List_Id
is
274 -- If all dimensions dealt with, we simply test the component
276 if N
> Number_Dimensions
(A_Type
) then
277 return Test_Component
;
279 -- Here we generate the required loop
283 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
285 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
288 Make_Implicit_Loop_Statement
(Nod
,
291 Make_Iteration_Scheme
(Loc
,
292 Loop_Parameter_Specification
=>
293 Make_Loop_Parameter_Specification
(Loc
,
294 Defining_Identifier
=> Index
,
295 Discrete_Subtype_Definition
=>
296 Make_Attribute_Reference
(Loc
,
297 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
298 Attribute_Name
=> Name_Range
,
299 Expressions
=> New_List
(
300 Make_Integer_Literal
(Loc
, N
))))),
301 Statements
=> Test_One_Dimension
(N
+ 1)),
302 Make_Simple_Return_Statement
(Loc
,
303 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
305 end Test_One_Dimension
;
307 -- Start of processing for Build_Array_VS_Func
310 Index_List
:= New_List
;
311 Body_Stmts
:= Test_One_Dimension
(1);
313 -- Parameter is always (A : A_Typ)
315 Formals
:= New_List
(
316 Make_Parameter_Specification
(Loc
,
317 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uA
),
319 Out_Present
=> False,
320 Parameter_Type
=> New_Occurrence_Of
(A_Type
, Loc
)));
324 Set_Ekind
(Func_Id
, E_Function
);
325 Set_Is_Internal
(Func_Id
);
328 Make_Subprogram_Body
(Loc
,
330 Make_Function_Specification
(Loc
,
331 Defining_Unit_Name
=> Func_Id
,
332 Parameter_Specifications
=> Formals
,
334 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
335 Declarations
=> New_List
,
336 Handled_Statement_Sequence
=>
337 Make_Handled_Sequence_Of_Statements
(Loc
,
338 Statements
=> Body_Stmts
)));
340 if not Debug_Generated_Code
then
341 Set_Debug_Info_Off
(Func_Id
);
344 Set_Is_Pure
(Func_Id
);
346 end Build_Array_VS_Func
;
348 --------------------------
349 -- Build_Record_VS_Func --
350 --------------------------
354 -- function _Valid_Scalars (X : T) return Boolean is
356 -- -- Check discriminants
358 -- if not X.D1'Valid_Scalars or else
359 -- not X.D2'Valid_Scalars or else
365 -- -- Check components
367 -- if not X.C1'Valid_Scalars or else
368 -- not X.C2'Valid_Scalars or else
374 -- -- Check variant part
378 -- if not X.C2'Valid_Scalars or else
379 -- not X.C3'Valid_Scalars or else
386 -- if not X.Cn'Valid_Scalars or else
394 -- end _Valid_Scalars;
396 function Build_Record_VS_Func
398 Nod
: Node_Id
) return Entity_Id
400 Loc
: constant Source_Ptr
:= Sloc
(R_Type
);
401 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
402 X
: constant Entity_Id
:= Make_Defining_Identifier
(Loc
, Name_X
);
404 function Make_VS_Case
407 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
;
408 -- Building block for variant valid scalars. Given a Component_List node
409 -- CL, it generates an 'if' followed by a 'case' statement that compares
410 -- all components of local temporaries named X and Y (that are declared
411 -- as formals at some upper level). E provides the Sloc to be used for
412 -- the generated code.
416 L
: List_Id
) return Node_Id
;
417 -- Building block for variant validate scalars. Given the list, L, of
418 -- components (or discriminants) L, it generates a return statement that
419 -- compares all components of local temporaries named X and Y (that are
420 -- declared as formals at some upper level). E provides the Sloc to be
421 -- used for the generated code.
427 -- <Make_VS_If on shared components>
430 -- when V1 => <Make_VS_Case> on subcomponents
432 -- when Vn => <Make_VS_Case> on subcomponents
435 function Make_VS_Case
438 Discrs
: Elist_Id
:= New_Elmt_List
) return List_Id
440 Loc
: constant Source_Ptr
:= Sloc
(E
);
441 Result
: constant List_Id
:= New_List
;
446 Append_To
(Result
, Make_VS_If
(E
, Component_Items
(CL
)));
448 if No
(Variant_Part
(CL
)) then
452 Variant
:= First_Non_Pragma
(Variants
(Variant_Part
(CL
)));
458 Alt_List
:= New_List
;
459 while Present
(Variant
) loop
461 Make_Case_Statement_Alternative
(Loc
,
462 Discrete_Choices
=> New_Copy_List
(Discrete_Choices
(Variant
)),
464 Make_VS_Case
(E
, Component_List
(Variant
), Discrs
)));
465 Next_Non_Pragma
(Variant
);
469 Make_Case_Statement
(Loc
,
471 Make_Selected_Component
(Loc
,
472 Prefix
=> Make_Identifier
(Loc
, Name_X
),
473 Selector_Name
=> New_Copy
(Name
(Variant_Part
(CL
)))),
474 Alternatives
=> Alt_List
));
486 -- not X.C1'Valid_Scalars
488 -- not X.C2'Valid_Scalars
494 -- or a null statement if the list L is empty
498 L
: List_Id
) return Node_Id
500 Loc
: constant Source_Ptr
:= Sloc
(E
);
503 Field_Name
: Name_Id
;
508 return Make_Null_Statement
(Loc
);
513 C
:= First_Non_Pragma
(L
);
514 while Present
(C
) loop
515 Def_Id
:= Defining_Identifier
(C
);
516 Field_Name
:= Chars
(Def_Id
);
518 -- The tags need not be checked since they will always be valid
520 -- Note also that in the following, we use Make_Identifier for
521 -- the component names. Use of New_Occurrence_Of to identify
522 -- the components would be incorrect because wrong entities for
523 -- discriminants could be picked up in the private type case.
525 -- Don't bother with abstract parent in interface case
527 if Field_Name
= Name_uParent
528 and then Is_Interface
(Etype
(Def_Id
))
532 -- Don't bother with tag, always valid, and not scalar anyway
534 elsif Field_Name
= Name_uTag
then
537 -- Don't bother with component with no scalar components
539 elsif not Scalar_Part_Present
(Etype
(Def_Id
)) then
542 -- Normal case, generate Valid_Scalars attribute reference
545 Evolve_Or_Else
(Cond
,
548 Make_Attribute_Reference
(Loc
,
550 Make_Selected_Component
(Loc
,
552 Make_Identifier
(Loc
, Name_X
),
554 Make_Identifier
(Loc
, Field_Name
)),
555 Attribute_Name
=> Name_Valid_Scalars
)));
562 return Make_Null_Statement
(Loc
);
566 Make_Implicit_If_Statement
(E
,
568 Then_Statements
=> New_List
(
569 Make_Simple_Return_Statement
(Loc
,
571 New_Occurrence_Of
(Standard_False
, Loc
))));
576 -- Local Declarations
578 Def
: constant Node_Id
:= Parent
(R_Type
);
579 Comps
: constant Node_Id
:= Component_List
(Type_Definition
(Def
));
580 Stmts
: constant List_Id
:= New_List
;
581 Pspecs
: constant List_Id
:= New_List
;
585 Make_Parameter_Specification
(Loc
,
586 Defining_Identifier
=> X
,
587 Parameter_Type
=> New_Occurrence_Of
(R_Type
, Loc
)));
590 Make_VS_If
(R_Type
, Discriminant_Specifications
(Def
)));
591 Append_List_To
(Stmts
, Make_VS_Case
(R_Type
, Comps
));
594 Make_Simple_Return_Statement
(Loc
,
595 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
598 Make_Subprogram_Body
(Loc
,
600 Make_Function_Specification
(Loc
,
601 Defining_Unit_Name
=> Func_Id
,
602 Parameter_Specifications
=> Pspecs
,
603 Result_Definition
=> New_Occurrence_Of
(Standard_Boolean
, Loc
)),
604 Declarations
=> New_List
,
605 Handled_Statement_Sequence
=>
606 Make_Handled_Sequence_Of_Statements
(Loc
, Statements
=> Stmts
)),
607 Suppress
=> Discriminant_Check
);
609 if not Debug_Generated_Code
then
610 Set_Debug_Info_Off
(Func_Id
);
613 Set_Is_Pure
(Func_Id
);
615 end Build_Record_VS_Func
;
617 ----------------------------------
618 -- Compile_Stream_Body_In_Scope --
619 ----------------------------------
621 procedure Compile_Stream_Body_In_Scope
627 Installed
: Boolean := False;
628 Scop
: constant Entity_Id
:= Scope
(Arr
);
629 Curr
: constant Entity_Id
:= Current_Scope
;
633 and then not In_Open_Scopes
(Scop
)
634 and then Ekind
(Scop
) = E_Package
636 -- If we are within an instance body, then all visibility has been
637 -- established already and there is no need to install the package.
639 and then not In_Instance_Body
642 Install_Visible_Declarations
(Scop
);
643 Install_Private_Declarations
(Scop
);
646 -- The entities in the package are now visible, but the generated
647 -- stream entity must appear in the current scope (usually an
648 -- enclosing stream function) so that itypes all have their proper
655 Insert_Action
(N
, Decl
);
657 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
662 -- Remove extra copy of current scope, and package itself
665 End_Package_Scope
(Scop
);
667 end Compile_Stream_Body_In_Scope
;
669 -----------------------------------
670 -- Expand_Access_To_Protected_Op --
671 -----------------------------------
673 procedure Expand_Access_To_Protected_Op
678 -- The value of the attribute_reference is a record containing two
679 -- fields: an access to the protected object, and an access to the
680 -- subprogram itself. The prefix is a selected component.
682 Loc
: constant Source_Ptr
:= Sloc
(N
);
684 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
687 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
688 Acc
: constant Entity_Id
:=
689 Etype
(Next_Component
(First_Component
(E_T
)));
693 -- Start of processing for Expand_Access_To_Protected_Op
696 -- Within the body of the protected type, the prefix designates a local
697 -- operation, and the object is the first parameter of the corresponding
698 -- protected body of the current enclosing operation.
700 if Is_Entity_Name
(Pref
) then
701 -- All indirect calls are external calls, so must do locking and
702 -- barrier reevaluation, even if the 'Access occurs within the
703 -- protected body. Hence the call to External_Subprogram, as opposed
704 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
705 -- that indirect calls from within the same protected body will
706 -- deadlock, as allowed by RM-9.5.1(8,15,17).
708 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
710 -- Don't traverse the scopes when the attribute occurs within an init
711 -- proc, because we directly use the _init formal of the init proc in
714 Curr
:= Current_Scope
;
715 if not Is_Init_Proc
(Curr
) then
716 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
718 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
719 Curr
:= Scope
(Curr
);
723 -- In case of protected entries the first formal of its Protected_
724 -- Body_Subprogram is the address of the object.
726 if Ekind
(Curr
) = E_Entry
then
730 (Protected_Body_Subprogram
(Curr
)), Loc
);
732 -- If the current scope is an init proc, then use the address of the
733 -- _init formal as the object reference.
735 elsif Is_Init_Proc
(Curr
) then
737 Make_Attribute_Reference
(Loc
,
738 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
739 Attribute_Name
=> Name_Address
);
741 -- In case of protected subprograms the first formal of its
742 -- Protected_Body_Subprogram is the object and we get its address.
746 Make_Attribute_Reference
(Loc
,
750 (Protected_Body_Subprogram
(Curr
)), Loc
),
751 Attribute_Name
=> Name_Address
);
754 -- Case where the prefix is not an entity name. Find the
755 -- version of the protected operation to be called from
756 -- outside the protected object.
762 (Entity
(Selector_Name
(Pref
))), Loc
);
765 Make_Attribute_Reference
(Loc
,
766 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
767 Attribute_Name
=> Name_Address
);
771 Make_Attribute_Reference
(Loc
,
773 Attribute_Name
=> Name_Access
);
775 -- We set the type of the access reference to the already generated
776 -- access_to_subprogram type, and declare the reference analyzed, to
777 -- prevent further expansion when the enclosing aggregate is analyzed.
779 Set_Etype
(Sub_Ref
, Acc
);
780 Set_Analyzed
(Sub_Ref
);
784 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
786 -- Sub_Ref has been marked as analyzed, but we still need to make sure
787 -- Sub is correctly frozen.
789 Freeze_Before
(N
, Entity
(Sub
));
792 Analyze_And_Resolve
(N
, E_T
);
794 -- For subsequent analysis, the node must retain its type. The backend
795 -- will replace it with the equivalent type where needed.
798 end Expand_Access_To_Protected_Op
;
800 --------------------------
801 -- Expand_Fpt_Attribute --
802 --------------------------
804 procedure Expand_Fpt_Attribute
810 Loc
: constant Source_Ptr
:= Sloc
(N
);
811 Typ
: constant Entity_Id
:= Etype
(N
);
815 -- The function name is the selected component Attr_xxx.yyy where
816 -- Attr_xxx is the package name, and yyy is the argument Nam.
818 -- Note: it would be more usual to have separate RE entries for each
819 -- of the entities in the Fat packages, but first they have identical
820 -- names (so we would have to have lots of renaming declarations to
821 -- meet the normal RE rule of separate names for all runtime entities),
822 -- and second there would be an awful lot of them.
825 Make_Selected_Component
(Loc
,
826 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
827 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
829 -- The generated call is given the provided set of parameters, and then
830 -- wrapped in a conversion which converts the result to the target type
831 -- We use the base type as the target because a range check may be
835 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
836 Make_Function_Call
(Loc
,
838 Parameter_Associations
=> Args
)));
840 Analyze_And_Resolve
(N
, Typ
);
841 end Expand_Fpt_Attribute
;
843 ----------------------------
844 -- Expand_Fpt_Attribute_R --
845 ----------------------------
847 -- The single argument is converted to its root type to call the
848 -- appropriate runtime function, with the actual call being built
849 -- by Expand_Fpt_Attribute
851 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
852 E1
: constant Node_Id
:= First
(Expressions
(N
));
856 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
858 (N
, Pkg
, Attribute_Name
(N
),
859 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
860 end Expand_Fpt_Attribute_R
;
862 -----------------------------
863 -- Expand_Fpt_Attribute_RI --
864 -----------------------------
866 -- The first argument is converted to its root type and the second
867 -- argument is converted to standard long long integer to call the
868 -- appropriate runtime function, with the actual call being built
869 -- by Expand_Fpt_Attribute
871 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
872 E1
: constant Node_Id
:= First
(Expressions
(N
));
875 E2
: constant Node_Id
:= Next
(E1
);
877 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
879 (N
, Pkg
, Attribute_Name
(N
),
881 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
882 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
883 end Expand_Fpt_Attribute_RI
;
885 -----------------------------
886 -- Expand_Fpt_Attribute_RR --
887 -----------------------------
889 -- The two arguments are converted to their root types to call the
890 -- appropriate runtime function, with the actual call being built
891 -- by Expand_Fpt_Attribute
893 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
894 E1
: constant Node_Id
:= First
(Expressions
(N
));
895 E2
: constant Node_Id
:= Next
(E1
);
900 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
902 (N
, Pkg
, Attribute_Name
(N
),
904 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
905 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
906 end Expand_Fpt_Attribute_RR
;
908 ---------------------------------
909 -- Expand_Loop_Entry_Attribute --
910 ---------------------------------
912 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
913 procedure Build_Conditional_Block
917 If_Stmt
: out Node_Id
;
918 Blk_Stmt
: out Node_Id
);
919 -- Create a block Blk_Stmt with an empty declarative list and a single
920 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
921 -- condition Cond. If_Stmt is Empty when there is no condition provided.
923 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
924 -- Determine whether loop statement N denotes an Ada 2012 iteration over
927 -----------------------------
928 -- Build_Conditional_Block --
929 -----------------------------
931 procedure Build_Conditional_Block
935 If_Stmt
: out Node_Id
;
936 Blk_Stmt
: out Node_Id
)
939 -- Do not reanalyze the original loop statement because it is simply
942 Set_Analyzed
(Loop_Stmt
);
945 Make_Block_Statement
(Loc
,
946 Declarations
=> New_List
,
947 Handled_Statement_Sequence
=>
948 Make_Handled_Sequence_Of_Statements
(Loc
,
949 Statements
=> New_List
(Loop_Stmt
)));
951 if Present
(Cond
) then
953 Make_If_Statement
(Loc
,
955 Then_Statements
=> New_List
(Blk_Stmt
));
959 end Build_Conditional_Block
;
961 ------------------------
962 -- Is_Array_Iteration --
963 ------------------------
965 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
966 Stmt
: constant Node_Id
:= Original_Node
(N
);
970 if Nkind
(Stmt
) = N_Loop_Statement
971 and then Present
(Iteration_Scheme
(Stmt
))
972 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
974 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
977 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
981 end Is_Array_Iteration
;
985 Exprs
: constant List_Id
:= Expressions
(N
);
986 Pref
: constant Node_Id
:= Prefix
(N
);
987 Typ
: constant Entity_Id
:= Etype
(Pref
);
1000 Temp_Id
: Entity_Id
;
1002 -- Start of processing for Expand_Loop_Entry_Attribute
1005 -- Step 1: Find the related loop
1007 -- The loop label variant of attribute 'Loop_Entry already has all the
1008 -- information in its expression.
1010 if Present
(Exprs
) then
1011 Loop_Id
:= Entity
(First
(Exprs
));
1012 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1014 -- Climb the parent chain to find the nearest enclosing loop. Skip all
1015 -- internally generated loops for quantified expressions.
1019 while Present
(Loop_Stmt
) loop
1020 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1021 and then Present
(Identifier
(Loop_Stmt
))
1026 Loop_Stmt
:= Parent
(Loop_Stmt
);
1029 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1032 Loc
:= Sloc
(Loop_Stmt
);
1034 -- Step 2: Transform the loop
1036 -- The loop has already been transformed during the expansion of a prior
1037 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1039 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1041 -- When the related loop name appears as the argument of attribute
1042 -- Loop_Entry, the corresponding label construct is the generated
1043 -- block statement. This is because the expander reuses the label.
1045 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1046 Decls
:= Declarations
(Loop_Stmt
);
1048 -- In all other cases, the loop must appear in the handled sequence
1049 -- of statements of the generated block.
1053 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1055 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1057 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1062 -- Transform the loop into a conditional block
1065 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1066 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1068 -- Infinite loops are transformed into:
1071 -- Temp1 : constant <type of Pref1> := <Pref1>;
1073 -- TempN : constant <type of PrefN> := <PrefN>;
1076 -- <original source statements with attribute rewrites>
1081 Build_Conditional_Block
(Loc
,
1083 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1089 -- While loops are transformed into:
1091 -- function Fnn return Boolean is
1093 -- <condition actions>
1094 -- return <condition>;
1099 -- Temp1 : constant <type of Pref1> := <Pref1>;
1101 -- TempN : constant <type of PrefN> := <PrefN>;
1104 -- <original source statements with attribute rewrites>
1105 -- exit when not Fnn;
1110 -- Note that loops over iterators and containers are already
1111 -- converted into while loops.
1113 elsif Present
(Condition
(Scheme
)) then
1115 Func_Decl
: Node_Id
;
1116 Func_Id
: Entity_Id
;
1120 -- Wrap the condition of the while loop in a Boolean function.
1121 -- This avoids the duplication of the same code which may lead
1122 -- to gigi issues with respect to multiple declaration of the
1123 -- same entity in the presence of side effects or checks. Note
1124 -- that the condition actions must also be relocated to the
1125 -- wrapping function.
1128 -- <condition actions>
1129 -- return <condition>;
1131 if Present
(Condition_Actions
(Scheme
)) then
1132 Stmts
:= Condition_Actions
(Scheme
);
1138 Make_Simple_Return_Statement
(Loc
,
1139 Expression
=> Relocate_Node
(Condition
(Scheme
))));
1142 -- function Fnn return Boolean is
1147 Func_Id
:= Make_Temporary
(Loc
, 'F');
1149 Make_Subprogram_Body
(Loc
,
1151 Make_Function_Specification
(Loc
,
1152 Defining_Unit_Name
=> Func_Id
,
1153 Result_Definition
=>
1154 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1155 Declarations
=> Empty_List
,
1156 Handled_Statement_Sequence
=>
1157 Make_Handled_Sequence_Of_Statements
(Loc
,
1158 Statements
=> Stmts
));
1160 -- The function is inserted before the related loop. Make sure
1161 -- to analyze it in the context of the loop's enclosing scope.
1163 Push_Scope
(Scope
(Loop_Id
));
1164 Insert_Action
(Loop_Stmt
, Func_Decl
);
1167 -- Transform the original while loop into an infinite loop
1168 -- where the last statement checks the negated condition. This
1169 -- placement ensures that the condition will not be evaluated
1170 -- twice on the first iteration.
1172 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1176 -- exit when not Fnn;
1178 Append_To
(Statements
(Loop_Stmt
),
1179 Make_Exit_Statement
(Loc
,
1183 Make_Function_Call
(Loc
,
1184 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1186 Build_Conditional_Block
(Loc
,
1188 Make_Function_Call
(Loc
,
1189 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1190 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1195 -- Ada 2012 iteration over an array is transformed into:
1197 -- if <Array_Nam>'Length (1) > 0
1198 -- and then <Array_Nam>'Length (N) > 0
1201 -- Temp1 : constant <type of Pref1> := <Pref1>;
1203 -- TempN : constant <type of PrefN> := <PrefN>;
1205 -- for X in ... loop -- multiple loops depending on dims
1206 -- <original source statements with attribute rewrites>
1211 elsif Is_Array_Iteration
(Loop_Stmt
) then
1213 Array_Nam
: constant Entity_Id
:=
1214 Entity
(Name
(Iterator_Specification
1215 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1216 Num_Dims
: constant Pos
:=
1217 Number_Dimensions
(Etype
(Array_Nam
));
1218 Cond
: Node_Id
:= Empty
;
1222 -- Generate a check which determines whether all dimensions of
1223 -- the array are non-null.
1225 for Dim
in 1 .. Num_Dims
loop
1229 Make_Attribute_Reference
(Loc
,
1230 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1231 Attribute_Name
=> Name_Length
,
1232 Expressions
=> New_List
(
1233 Make_Integer_Literal
(Loc
, Dim
))),
1235 Make_Integer_Literal
(Loc
, 0));
1243 Right_Opnd
=> Check
);
1247 Build_Conditional_Block
(Loc
,
1249 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1254 -- For loops are transformed into:
1256 -- if <Low> <= <High> then
1258 -- Temp1 : constant <type of Pref1> := <Pref1>;
1260 -- TempN : constant <type of PrefN> := <PrefN>;
1262 -- for <Def_Id> in <Low> .. <High> loop
1263 -- <original source statements with attribute rewrites>
1268 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1270 Loop_Spec
: constant Node_Id
:=
1271 Loop_Parameter_Specification
(Scheme
);
1276 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1278 -- When the loop iterates over a subtype indication with a
1279 -- range, use the low and high bounds of the subtype itself.
1281 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1282 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1285 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1292 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1293 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1295 Build_Conditional_Block
(Loc
,
1297 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1303 Decls
:= Declarations
(Blk
);
1306 -- Step 3: Create a constant to capture the value of the prefix at the
1307 -- entry point into the loop.
1309 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1311 -- Preserve the tag of the prefix by offering a specific view of the
1312 -- class-wide version of the prefix.
1314 if Is_Tagged_Type
(Typ
) then
1317 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
1319 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1320 CW_Typ
:= Class_Wide_Type
(Typ
);
1323 Make_Object_Declaration
(Loc
,
1324 Defining_Identifier
=> CW_Temp
,
1325 Constant_Present
=> True,
1326 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1328 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1329 Append_To
(Decls
, CW_Decl
);
1332 -- Temp : Typ renames Typ (CW_Temp);
1335 Make_Object_Renaming_Declaration
(Loc
,
1336 Defining_Identifier
=> Temp_Id
,
1337 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
1339 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1340 Append_To
(Decls
, Temp_Decl
);
1348 -- Temp : constant Typ := Pref;
1351 Make_Object_Declaration
(Loc
,
1352 Defining_Identifier
=> Temp_Id
,
1353 Constant_Present
=> True,
1354 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
1355 Expression
=> Relocate_Node
(Pref
));
1356 Append_To
(Decls
, Temp_Decl
);
1359 -- Step 4: Analyze all bits
1361 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1363 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1364 -- associated loop, ensure the proper visibility for analysis.
1366 if not Installed
then
1367 Push_Scope
(Scope
(Loop_Id
));
1370 -- The analysis of the conditional block takes care of the constant
1373 if Present
(Result
) then
1374 Rewrite
(Loop_Stmt
, Result
);
1375 Analyze
(Loop_Stmt
);
1377 -- The conditional block was analyzed when a previous 'Loop_Entry was
1378 -- expanded. There is no point in reanalyzing the block, simply analyze
1379 -- the declaration of the constant.
1382 if Present
(CW_Decl
) then
1386 Analyze
(Temp_Decl
);
1389 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1392 if not Installed
then
1395 end Expand_Loop_Entry_Attribute
;
1397 ------------------------------
1398 -- Expand_Min_Max_Attribute --
1399 ------------------------------
1401 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1403 -- Min and Max are handled by the back end (except that static cases
1404 -- have already been evaluated during semantic processing, although the
1405 -- back end should not count on this). The one bit of special processing
1406 -- required in the normal case is that these two attributes typically
1407 -- generate conditionals in the code, so check the relevant restriction.
1409 Check_Restriction
(No_Implicit_Conditionals
, N
);
1411 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1413 if Modify_Tree_For_C
then
1415 Loc
: constant Source_Ptr
:= Sloc
(N
);
1416 Typ
: constant Entity_Id
:= Etype
(N
);
1417 Expr
: constant Node_Id
:= First
(Expressions
(N
));
1418 Left
: constant Node_Id
:= Relocate_Node
(Expr
);
1419 Right
: constant Node_Id
:= Relocate_Node
(Next
(Expr
));
1421 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
;
1422 -- Returns Left >= Right for Max, Left <= Right for Min
1428 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
is
1430 if Attribute_Name
(N
) = Name_Max
then
1434 Right_Opnd
=> Right
);
1439 Right_Opnd
=> Right
);
1443 -- Start of processing for Min_Max
1446 -- If both Left and Right are side effect free, then we can just
1447 -- use Duplicate_Expr to duplicate the references and return
1449 -- (if Left >=|<= Right then Left else Right)
1451 if Side_Effect_Free
(Left
) and then Side_Effect_Free
(Right
) then
1453 Make_If_Expression
(Loc
,
1454 Expressions
=> New_List
(
1455 Make_Compare
(Left
, Right
),
1456 Duplicate_Subexpr_No_Checks
(Left
),
1457 Duplicate_Subexpr_No_Checks
(Right
))));
1459 -- Otherwise we generate declarations to capture the values. We
1460 -- can't put these declarations inside the if expression, since
1461 -- we could end up with an N_Expression_With_Actions which has
1462 -- declarations in the actions, forbidden for Modify_Tree_For_C.
1464 -- The translation is
1466 -- T1 : styp; -- inserted high up in tree
1467 -- T2 : styp; -- inserted high up in tree
1470 -- T1 := styp!(Left);
1471 -- T2 := styp!(Right);
1473 -- (if T1 >=|<= T2 then typ!(T1) else typ!(T2))
1476 -- We insert the T1,T2 declarations with Insert_Declaration which
1477 -- inserts these declarations high up in the tree unconditionally.
1478 -- This is safe since no code is associated with the declarations.
1479 -- Here styp is a standard type whose Esize matches the size of
1480 -- our type. We do this because the actual type may be a result of
1481 -- some local declaration which would not be visible at the point
1482 -- where we insert the declarations of T1 and T2.
1486 T1
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1487 T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1488 Styp
: constant Entity_Id
:= Matching_Standard_Type
(Typ
);
1491 Insert_Declaration
(N
,
1492 Make_Object_Declaration
(Loc
,
1493 Defining_Identifier
=> T1
,
1494 Object_Definition
=> New_Occurrence_Of
(Styp
, Loc
)));
1496 Insert_Declaration
(N
,
1497 Make_Object_Declaration
(Loc
,
1498 Defining_Identifier
=> T2
,
1499 Object_Definition
=> New_Occurrence_Of
(Styp
, Loc
)));
1502 Make_Expression_With_Actions
(Loc
,
1503 Actions
=> New_List
(
1504 Make_Assignment_Statement
(Loc
,
1505 Name
=> New_Occurrence_Of
(T1
, Loc
),
1506 Expression
=> Unchecked_Convert_To
(Styp
, Left
)),
1507 Make_Assignment_Statement
(Loc
,
1508 Name
=> New_Occurrence_Of
(T2
, Loc
),
1509 Expression
=> Unchecked_Convert_To
(Styp
, Right
))),
1512 Make_If_Expression
(Loc
,
1513 Expressions
=> New_List
(
1515 (New_Occurrence_Of
(T1
, Loc
),
1516 New_Occurrence_Of
(T2
, Loc
)),
1517 Unchecked_Convert_To
(Typ
,
1518 New_Occurrence_Of
(T1
, Loc
)),
1519 Unchecked_Convert_To
(Typ
,
1520 New_Occurrence_Of
(T2
, Loc
))))));
1524 Analyze_And_Resolve
(N
, Typ
);
1527 end Expand_Min_Max_Attribute
;
1529 ----------------------------------
1530 -- Expand_N_Attribute_Reference --
1531 ----------------------------------
1533 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1534 Loc
: constant Source_Ptr
:= Sloc
(N
);
1535 Typ
: constant Entity_Id
:= Etype
(N
);
1536 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1537 Pref
: constant Node_Id
:= Prefix
(N
);
1538 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1539 Exprs
: constant List_Id
:= Expressions
(N
);
1540 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1542 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1543 -- Rewrites a stream attribute for Read, Write or Output with the
1544 -- procedure call. Pname is the entity for the procedure to call.
1546 ------------------------------
1547 -- Rewrite_Stream_Proc_Call --
1548 ------------------------------
1550 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1551 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1552 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1553 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1554 Is_Written
: constant Boolean := (Ekind
(Formal
) /= E_In_Parameter
);
1557 -- The expansion depends on Item, the second actual, which is
1558 -- the object being streamed in or out.
1560 -- If the item is a component of a packed array type, and
1561 -- a conversion is needed on exit, we introduce a temporary to
1562 -- hold the value, because otherwise the packed reference will
1563 -- not be properly expanded.
1565 if Nkind
(Item
) = N_Indexed_Component
1566 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1567 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1571 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1577 Make_Object_Declaration
(Loc
,
1578 Defining_Identifier
=> Temp
,
1579 Object_Definition
=>
1580 New_Occurrence_Of
(Formal_Typ
, Loc
));
1581 Set_Etype
(Temp
, Formal_Typ
);
1584 Make_Assignment_Statement
(Loc
,
1585 Name
=> New_Copy_Tree
(Item
),
1587 Unchecked_Convert_To
1588 (Etype
(Item
), New_Occurrence_Of
(Temp
, Loc
)));
1590 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1594 Make_Procedure_Call_Statement
(Loc
,
1595 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1596 Parameter_Associations
=> Exprs
),
1599 Rewrite
(N
, Make_Null_Statement
(Loc
));
1604 -- For the class-wide dispatching cases, and for cases in which
1605 -- the base type of the second argument matches the base type of
1606 -- the corresponding formal parameter (that is to say the stream
1607 -- operation is not inherited), we are all set, and can use the
1608 -- argument unchanged.
1610 -- For all other cases we do an unchecked conversion of the second
1611 -- parameter to the type of the formal of the procedure we are
1612 -- calling. This deals with the private type cases, and with going
1613 -- to the root type as required in elementary type case.
1615 if not Is_Class_Wide_Type
(Entity
(Pref
))
1616 and then not Is_Class_Wide_Type
(Etype
(Item
))
1617 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1620 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1622 -- For untagged derived types set Assignment_OK, to prevent
1623 -- copies from being created when the unchecked conversion
1624 -- is expanded (which would happen in Remove_Side_Effects
1625 -- if Expand_N_Unchecked_Conversion were allowed to call
1626 -- Force_Evaluation). The copy could violate Ada semantics in
1627 -- cases such as an actual that is an out parameter. Note that
1628 -- this approach is also used in exp_ch7 for calls to controlled
1629 -- type operations to prevent problems with actuals wrapped in
1630 -- unchecked conversions.
1632 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1633 Set_Assignment_OK
(Item
);
1637 -- The stream operation to call may be a renaming created by an
1638 -- attribute definition clause, and may not be frozen yet. Ensure
1639 -- that it has the necessary extra formals.
1641 if not Is_Frozen
(Pname
) then
1642 Create_Extra_Formals
(Pname
);
1645 -- And now rewrite the call
1648 Make_Procedure_Call_Statement
(Loc
,
1649 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1650 Parameter_Associations
=> Exprs
));
1653 end Rewrite_Stream_Proc_Call
;
1655 -- Start of processing for Expand_N_Attribute_Reference
1658 -- Do required validity checking, if enabled. Do not apply check to
1659 -- output parameters of an Asm instruction, since the value of this
1660 -- is not set till after the attribute has been elaborated, and do
1661 -- not apply the check to the arguments of a 'Read or 'Input attribute
1662 -- reference since the scalar argument is an OUT scalar.
1664 if Validity_Checks_On
and then Validity_Check_Operands
1665 and then Id
/= Attribute_Asm_Output
1666 and then Id
/= Attribute_Read
1667 and then Id
/= Attribute_Input
1672 Expr
:= First
(Expressions
(N
));
1673 while Present
(Expr
) loop
1674 Ensure_Valid
(Expr
);
1680 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1681 -- place function, then a temporary return object needs to be created
1682 -- and access to it must be passed to the function. Currently we limit
1683 -- such functions to those with inherently limited result subtypes, but
1684 -- eventually we plan to expand the functions that are treated as
1685 -- build-in-place to include other composite result types.
1687 if Ada_Version
>= Ada_2005
1688 and then Is_Build_In_Place_Function_Call
(Pref
)
1690 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1693 -- If prefix is a protected type name, this is a reference to the
1694 -- current instance of the type. For a component definition, nothing
1695 -- to do (expansion will occur in the init proc). In other contexts,
1696 -- rewrite into reference to current instance.
1698 if Is_Protected_Self_Reference
(Pref
)
1700 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1701 N_Discriminant_Association
)
1702 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1703 N_Component_Definition
)
1705 -- No action needed for these attributes since the current instance
1706 -- will be rewritten to be the name of the _object parameter
1707 -- associated with the enclosing protected subprogram (see below).
1709 and then Id
/= Attribute_Access
1710 and then Id
/= Attribute_Unchecked_Access
1711 and then Id
/= Attribute_Unrestricted_Access
1713 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1717 -- Remaining processing depends on specific attribute
1719 -- Note: individual sections of the following case statement are
1720 -- allowed to assume there is no code after the case statement, and
1721 -- are legitimately allowed to execute return statements if they have
1722 -- nothing more to do.
1726 -- Attributes related to Ada 2012 iterators
1728 when Attribute_Constant_Indexing |
1729 Attribute_Default_Iterator |
1730 Attribute_Implicit_Dereference |
1731 Attribute_Iterable |
1732 Attribute_Iterator_Element |
1733 Attribute_Variable_Indexing
=>
1736 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1737 -- were already rejected by the parser. Thus they shouldn't appear here.
1739 when Internal_Attribute_Id
=>
1740 raise Program_Error
;
1746 when Attribute_Access |
1747 Attribute_Unchecked_Access |
1748 Attribute_Unrestricted_Access
=>
1750 Access_Cases
: declare
1751 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1752 Btyp_DDT
: Entity_Id
;
1754 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1755 -- If N denotes a compound name (selected component, indexed
1756 -- component, or slice), returns the name of the outermost such
1757 -- enclosing object. Otherwise returns N. If the object is a
1758 -- renaming, then the renamed object is returned.
1760 ----------------------
1761 -- Enclosing_Object --
1762 ----------------------
1764 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1769 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1770 N_Indexed_Component
,
1773 Obj_Name
:= Prefix
(Obj_Name
);
1776 return Get_Referenced_Object
(Obj_Name
);
1777 end Enclosing_Object
;
1779 -- Local declarations
1781 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1783 -- Start of processing for Access_Cases
1786 Btyp_DDT
:= Designated_Type
(Btyp
);
1788 -- Handle designated types that come from the limited view
1790 if From_Limited_With
(Btyp_DDT
)
1791 and then Has_Non_Limited_View
(Btyp_DDT
)
1793 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
1796 -- In order to improve the text of error messages, the designated
1797 -- type of access-to-subprogram itypes is set by the semantics as
1798 -- the associated subprogram entity (see sem_attr). Now we replace
1799 -- such node with the proper E_Subprogram_Type itype.
1801 if Id
= Attribute_Unrestricted_Access
1802 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
1804 -- The following conditions ensure that this special management
1805 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1806 -- At this stage other cases in which the designated type is
1807 -- still a subprogram (instead of an E_Subprogram_Type) are
1808 -- wrong because the semantics must have overridden the type of
1809 -- the node with the type imposed by the context.
1811 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
1812 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
1814 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
1818 Subp
: constant Entity_Id
:=
1819 Directly_Designated_Type
(Typ
);
1821 Extra
: Entity_Id
:= Empty
;
1822 New_Formal
: Entity_Id
;
1823 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1824 Subp_Typ
: Entity_Id
;
1827 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
1828 Set_Etype
(Subp_Typ
, Etype
(Subp
));
1829 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1831 if Present
(Old_Formal
) then
1832 New_Formal
:= New_Copy
(Old_Formal
);
1833 Set_First_Entity
(Subp_Typ
, New_Formal
);
1836 Set_Scope
(New_Formal
, Subp_Typ
);
1837 Etyp
:= Etype
(New_Formal
);
1839 -- Handle itypes. There is no need to duplicate
1840 -- here the itypes associated with record types
1841 -- (i.e the implicit full view of private types).
1844 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
1846 Extra
:= New_Copy
(Etyp
);
1847 Set_Parent
(Extra
, New_Formal
);
1848 Set_Etype
(New_Formal
, Extra
);
1849 Set_Scope
(Extra
, Subp_Typ
);
1852 Extra
:= New_Formal
;
1853 Next_Formal
(Old_Formal
);
1854 exit when No
(Old_Formal
);
1856 Set_Next_Entity
(New_Formal
,
1857 New_Copy
(Old_Formal
));
1858 Next_Entity
(New_Formal
);
1861 Set_Next_Entity
(New_Formal
, Empty
);
1862 Set_Last_Entity
(Subp_Typ
, Extra
);
1865 -- Now that the explicit formals have been duplicated,
1866 -- any extra formals needed by the subprogram must be
1869 if Present
(Extra
) then
1870 Set_Extra_Formal
(Extra
, Empty
);
1873 Create_Extra_Formals
(Subp_Typ
);
1874 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
1879 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
1880 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
1882 -- If prefix is a type name, this is a reference to the current
1883 -- instance of the type, within its initialization procedure.
1885 elsif Is_Entity_Name
(Pref
)
1886 and then Is_Type
(Entity
(Pref
))
1893 -- If the current instance name denotes a task type, then
1894 -- the access attribute is rewritten to be the name of the
1895 -- "_task" parameter associated with the task type's task
1896 -- procedure. An unchecked conversion is applied to ensure
1897 -- a type match in cases of expander-generated calls (e.g.
1900 if Is_Task_Type
(Entity
(Pref
)) then
1902 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
1903 while Present
(Formal
) loop
1904 exit when Chars
(Formal
) = Name_uTask
;
1905 Next_Entity
(Formal
);
1908 pragma Assert
(Present
(Formal
));
1911 Unchecked_Convert_To
(Typ
,
1912 New_Occurrence_Of
(Formal
, Loc
)));
1915 elsif Is_Protected_Type
(Entity
(Pref
)) then
1917 -- No action needed for current instance located in a
1918 -- component definition (expansion will occur in the
1921 if Is_Protected_Type
(Current_Scope
) then
1924 -- If the current instance reference is located in a
1925 -- protected subprogram or entry then rewrite the access
1926 -- attribute to be the name of the "_object" parameter.
1927 -- An unchecked conversion is applied to ensure a type
1928 -- match in cases of expander-generated calls (e.g. init
1931 -- The code may be nested in a block, so find enclosing
1932 -- scope that is a protected operation.
1939 Subp
:= Current_Scope
;
1940 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
1941 Subp
:= Scope
(Subp
);
1946 (Protected_Body_Subprogram
(Subp
));
1948 -- For a protected subprogram the _Object parameter
1949 -- is the protected record, so we create an access
1950 -- to it. The _Object parameter of an entry is an
1953 if Ekind
(Subp
) = E_Entry
then
1955 Unchecked_Convert_To
(Typ
,
1956 New_Occurrence_Of
(Formal
, Loc
)));
1961 Unchecked_Convert_To
(Typ
,
1962 Make_Attribute_Reference
(Loc
,
1963 Attribute_Name
=> Name_Unrestricted_Access
,
1965 New_Occurrence_Of
(Formal
, Loc
))));
1966 Analyze_And_Resolve
(N
);
1971 -- The expression must appear in a default expression,
1972 -- (which in the initialization procedure is the right-hand
1973 -- side of an assignment), and not in a discriminant
1978 while Present
(Par
) loop
1979 exit when Nkind
(Par
) = N_Assignment_Statement
;
1981 if Nkind
(Par
) = N_Component_Declaration
then
1985 Par
:= Parent
(Par
);
1988 if Present
(Par
) then
1990 Make_Attribute_Reference
(Loc
,
1991 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1992 Attribute_Name
=> Attribute_Name
(N
)));
1994 Analyze_And_Resolve
(N
, Typ
);
1999 -- If the prefix of an Access attribute is a dereference of an
2000 -- access parameter (or a renaming of such a dereference, or a
2001 -- subcomponent of such a dereference) and the context is a
2002 -- general access type (including the type of an object or
2003 -- component with an access_definition, but not the anonymous
2004 -- type of an access parameter or access discriminant), then
2005 -- apply an accessibility check to the access parameter. We used
2006 -- to rewrite the access parameter as a type conversion, but that
2007 -- could only be done if the immediate prefix of the Access
2008 -- attribute was the dereference, and didn't handle cases where
2009 -- the attribute is applied to a subcomponent of the dereference,
2010 -- since there's generally no available, appropriate access type
2011 -- to convert to in that case. The attribute is passed as the
2012 -- point to insert the check, because the access parameter may
2013 -- come from a renaming, possibly in a different scope, and the
2014 -- check must be associated with the attribute itself.
2016 elsif Id
= Attribute_Access
2017 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2018 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2019 and then (Ekind
(Btyp
) = E_General_Access_Type
2020 or else Is_Local_Anonymous_Access
(Btyp
))
2021 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
2022 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2023 = E_Anonymous_Access_Type
2024 and then Present
(Extra_Accessibility
2025 (Entity
(Prefix
(Enc_Object
))))
2027 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2029 -- Ada 2005 (AI-251): If the designated type is an interface we
2030 -- add an implicit conversion to force the displacement of the
2031 -- pointer to reference the secondary dispatch table.
2033 elsif Is_Interface
(Btyp_DDT
)
2034 and then (Comes_From_Source
(N
)
2035 or else Comes_From_Source
(Ref_Object
)
2036 or else (Nkind
(Ref_Object
) in N_Has_Chars
2037 and then Chars
(Ref_Object
) = Name_uInit
))
2039 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2041 -- No implicit conversion required if types match, or if
2042 -- the prefix is the class_wide_type of the interface. In
2043 -- either case passing an object of the interface type has
2044 -- already set the pointer correctly.
2046 if Btyp_DDT
= Etype
(Ref_Object
)
2047 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2049 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2054 Rewrite
(Prefix
(N
),
2055 Convert_To
(Btyp_DDT
,
2056 New_Copy_Tree
(Prefix
(N
))));
2058 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2061 -- When the object is an explicit dereference, convert the
2062 -- dereference's prefix.
2066 Obj_DDT
: constant Entity_Id
:=
2068 (Directly_Designated_Type
2069 (Etype
(Prefix
(Ref_Object
))));
2071 -- No implicit conversion required if designated types
2072 -- match, or if we have an unrestricted access.
2074 if Obj_DDT
/= Btyp_DDT
2075 and then Id
/= Attribute_Unrestricted_Access
2076 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2077 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2081 New_Copy_Tree
(Prefix
(Ref_Object
))));
2082 Analyze_And_Resolve
(N
, Typ
);
2093 -- Transforms 'Adjacent into a call to the floating-point attribute
2094 -- function Adjacent in Fat_xxx (where xxx is the root type)
2096 when Attribute_Adjacent
=>
2097 Expand_Fpt_Attribute_RR
(N
);
2103 when Attribute_Address
=> Address
: declare
2104 Task_Proc
: Entity_Id
;
2107 -- If the prefix is a task or a task type, the useful address is that
2108 -- of the procedure for the task body, i.e. the actual program unit.
2109 -- We replace the original entity with that of the procedure.
2111 if Is_Entity_Name
(Pref
)
2112 and then Is_Task_Type
(Entity
(Pref
))
2114 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2116 while Present
(Task_Proc
) loop
2117 exit when Ekind
(Task_Proc
) = E_Procedure
2118 and then Etype
(First_Formal
(Task_Proc
)) =
2119 Corresponding_Record_Type
(Ptyp
);
2120 Next_Entity
(Task_Proc
);
2123 if Present
(Task_Proc
) then
2124 Set_Entity
(Pref
, Task_Proc
);
2125 Set_Etype
(Pref
, Etype
(Task_Proc
));
2128 -- Similarly, the address of a protected operation is the address
2129 -- of the corresponding protected body, regardless of the protected
2130 -- object from which it is selected.
2132 elsif Nkind
(Pref
) = N_Selected_Component
2133 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2134 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2138 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2140 elsif Nkind
(Pref
) = N_Explicit_Dereference
2141 and then Ekind
(Ptyp
) = E_Subprogram_Type
2142 and then Convention
(Ptyp
) = Convention_Protected
2144 -- The prefix is be a dereference of an access_to_protected_
2145 -- subprogram. The desired address is the second component of
2146 -- the record that represents the access.
2149 Addr
: constant Entity_Id
:= Etype
(N
);
2150 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2151 T
: constant Entity_Id
:=
2152 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2156 Unchecked_Convert_To
(Addr
,
2157 Make_Selected_Component
(Loc
,
2158 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2159 Selector_Name
=> New_Occurrence_Of
(
2160 Next_Entity
(First_Entity
(T
)), Loc
))));
2162 Analyze_And_Resolve
(N
, Addr
);
2165 -- Ada 2005 (AI-251): Class-wide interface objects are always
2166 -- "displaced" to reference the tag associated with the interface
2167 -- type. In order to obtain the real address of such objects we
2168 -- generate a call to a run-time subprogram that returns the base
2169 -- address of the object.
2171 -- This processing is not needed in the VM case, where dispatching
2172 -- issues are taken care of by the virtual machine.
2174 elsif Is_Class_Wide_Type
(Ptyp
)
2175 and then Is_Interface
(Ptyp
)
2176 and then Tagged_Type_Expansion
2177 and then not (Nkind
(Pref
) in N_Has_Entity
2178 and then Is_Subprogram
(Entity
(Pref
)))
2181 Make_Function_Call
(Loc
,
2182 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2183 Parameter_Associations
=> New_List
(
2184 Relocate_Node
(N
))));
2189 -- Deal with packed array reference, other cases are handled by
2192 if Involves_Packed_Array_Reference
(Pref
) then
2193 Expand_Packed_Address_Reference
(N
);
2201 when Attribute_Alignment
=> Alignment
: declare
2205 -- For class-wide types, X'Class'Alignment is transformed into a
2206 -- direct reference to the Alignment of the class type, so that the
2207 -- back end does not have to deal with the X'Class'Alignment
2210 if Is_Entity_Name
(Pref
)
2211 and then Is_Class_Wide_Type
(Entity
(Pref
))
2213 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2216 -- For x'Alignment applied to an object of a class wide type,
2217 -- transform X'Alignment into a call to the predefined primitive
2218 -- operation _Alignment applied to X.
2220 elsif Is_Class_Wide_Type
(Ptyp
) then
2222 Make_Attribute_Reference
(Loc
,
2224 Attribute_Name
=> Name_Tag
);
2226 if VM_Target
= No_VM
then
2227 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2230 Make_Function_Call
(Loc
,
2231 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Alignment
), Loc
),
2232 Parameter_Associations
=> New_List
(New_Node
));
2235 -- Case where the context is a specific integer type with which
2236 -- the original attribute was compatible. The function has a
2237 -- specific type as well, so to preserve the compatibility we
2238 -- must convert explicitly.
2240 if Typ
/= Standard_Integer
then
2241 New_Node
:= Convert_To
(Typ
, New_Node
);
2244 Rewrite
(N
, New_Node
);
2245 Analyze_And_Resolve
(N
, Typ
);
2248 -- For all other cases, we just have to deal with the case of
2249 -- the fact that the result can be universal.
2252 Apply_Universal_Integer_Attribute_Checks
(N
);
2260 -- We compute this if a packed array reference was present, otherwise we
2261 -- leave the computation up to the back end.
2263 when Attribute_Bit
=>
2264 if Involves_Packed_Array_Reference
(Pref
) then
2265 Expand_Packed_Bit_Reference
(N
);
2267 Apply_Universal_Integer_Attribute_Checks
(N
);
2274 -- We compute this if a component clause was present, otherwise we leave
2275 -- the computation up to the back end, since we don't know what layout
2278 -- Note that the attribute can apply to a naked record component
2279 -- in generated code (i.e. the prefix is an identifier that
2280 -- references the component or discriminant entity).
2282 when Attribute_Bit_Position
=> Bit_Position
: declare
2286 if Nkind
(Pref
) = N_Identifier
then
2287 CE
:= Entity
(Pref
);
2289 CE
:= Entity
(Selector_Name
(Pref
));
2292 if Known_Static_Component_Bit_Offset
(CE
) then
2294 Make_Integer_Literal
(Loc
,
2295 Intval
=> Component_Bit_Offset
(CE
)));
2296 Analyze_And_Resolve
(N
, Typ
);
2299 Apply_Universal_Integer_Attribute_Checks
(N
);
2307 -- A reference to P'Body_Version or P'Version is expanded to
2310 -- pragma Import (C, Vnn, "uuuuT");
2312 -- Get_Version_String (Vnn)
2314 -- where uuuu is the unit name (dots replaced by double underscore)
2315 -- and T is B for the cases of Body_Version, or Version applied to a
2316 -- subprogram acting as its own spec, and S for Version applied to a
2317 -- subprogram spec or package. This sequence of code references the
2318 -- unsigned constant created in the main program by the binder.
2320 -- A special exception occurs for Standard, where the string returned
2321 -- is a copy of the library string in gnatvsn.ads.
2323 when Attribute_Body_Version | Attribute_Version
=> Version
: declare
2324 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2329 -- If not library unit, get to containing library unit
2331 Pent
:= Entity
(Pref
);
2332 while Pent
/= Standard_Standard
2333 and then Scope
(Pent
) /= Standard_Standard
2334 and then not Is_Child_Unit
(Pent
)
2336 Pent
:= Scope
(Pent
);
2339 -- Special case Standard and Standard.ASCII
2341 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2343 Make_String_Literal
(Loc
,
2344 Strval
=> Verbose_Library_Version
));
2349 -- Build required string constant
2351 Get_Name_String
(Get_Unit_Name
(Pent
));
2354 for J
in 1 .. Name_Len
- 2 loop
2355 if Name_Buffer
(J
) = '.' then
2356 Store_String_Chars
("__");
2358 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2362 -- Case of subprogram acting as its own spec, always use body
2364 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2365 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2367 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2369 Store_String_Chars
("B");
2371 -- Case of no body present, always use spec
2373 elsif not Unit_Requires_Body
(Pent
) then
2374 Store_String_Chars
("S");
2376 -- Otherwise use B for Body_Version, S for spec
2378 elsif Id
= Attribute_Body_Version
then
2379 Store_String_Chars
("B");
2381 Store_String_Chars
("S");
2385 Lib
.Version_Referenced
(S
);
2387 -- Insert the object declaration
2389 Insert_Actions
(N
, New_List
(
2390 Make_Object_Declaration
(Loc
,
2391 Defining_Identifier
=> E
,
2392 Object_Definition
=>
2393 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2395 -- Set entity as imported with correct external name
2397 Set_Is_Imported
(E
);
2398 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2400 -- Set entity as internal to ensure proper Sprint output of its
2401 -- implicit importation.
2403 Set_Is_Internal
(E
);
2405 -- And now rewrite original reference
2408 Make_Function_Call
(Loc
,
2409 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2410 Parameter_Associations
=> New_List
(
2411 New_Occurrence_Of
(E
, Loc
))));
2414 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2421 -- Transforms 'Ceiling into a call to the floating-point attribute
2422 -- function Ceiling in Fat_xxx (where xxx is the root type)
2424 when Attribute_Ceiling
=>
2425 Expand_Fpt_Attribute_R
(N
);
2431 -- Transforms 'Callable attribute into a call to the Callable function
2433 when Attribute_Callable
=> Callable
:
2435 -- We have an object of a task interface class-wide type as a prefix
2436 -- to Callable. Generate:
2437 -- callable (Task_Id (Pref._disp_get_task_id));
2439 if Ada_Version
>= Ada_2005
2440 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2441 and then Is_Interface
(Ptyp
)
2442 and then Is_Task_Interface
(Ptyp
)
2445 Make_Function_Call
(Loc
,
2447 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2448 Parameter_Associations
=> New_List
(
2449 Make_Unchecked_Type_Conversion
(Loc
,
2451 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2453 Make_Selected_Component
(Loc
,
2455 New_Copy_Tree
(Pref
),
2457 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
2461 Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2464 Analyze_And_Resolve
(N
, Standard_Boolean
);
2471 -- Transforms 'Caller attribute into a call to either the
2472 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2474 when Attribute_Caller
=> Caller
: declare
2475 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2476 Ent
: constant Entity_Id
:= Entity
(Pref
);
2477 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2478 Nest_Depth
: Integer := 0;
2485 if Is_Protected_Type
(Conctype
) then
2486 case Corresponding_Runtime_Package
(Conctype
) is
2487 when System_Tasking_Protected_Objects_Entries
=>
2490 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2492 when System_Tasking_Protected_Objects_Single_Entry
=>
2495 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2498 raise Program_Error
;
2502 Unchecked_Convert_To
(Id_Kind
,
2503 Make_Function_Call
(Loc
,
2505 Parameter_Associations
=> New_List
(
2507 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2512 -- Determine the nesting depth of the E'Caller attribute, that
2513 -- is, how many accept statements are nested within the accept
2514 -- statement for E at the point of E'Caller. The runtime uses
2515 -- this depth to find the specified entry call.
2517 for J
in reverse 0 .. Scope_Stack
.Last
loop
2518 S
:= Scope_Stack
.Table
(J
).Entity
;
2520 -- We should not reach the scope of the entry, as it should
2521 -- already have been checked in Sem_Attr that this attribute
2522 -- reference is within a matching accept statement.
2524 pragma Assert
(S
/= Conctype
);
2529 elsif Is_Entry
(S
) then
2530 Nest_Depth
:= Nest_Depth
+ 1;
2535 Unchecked_Convert_To
(Id_Kind
,
2536 Make_Function_Call
(Loc
,
2538 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2539 Parameter_Associations
=> New_List
(
2540 Make_Integer_Literal
(Loc
,
2541 Intval
=> Int
(Nest_Depth
))))));
2544 Analyze_And_Resolve
(N
, Id_Kind
);
2551 -- Transforms 'Compose into a call to the floating-point attribute
2552 -- function Compose in Fat_xxx (where xxx is the root type)
2554 -- Note: we strictly should have special code here to deal with the
2555 -- case of absurdly negative arguments (less than Integer'First)
2556 -- which will return a (signed) zero value, but it hardly seems
2557 -- worth the effort. Absurdly large positive arguments will raise
2558 -- constraint error which is fine.
2560 when Attribute_Compose
=>
2561 Expand_Fpt_Attribute_RI
(N
);
2567 when Attribute_Constrained
=> Constrained
: declare
2568 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2570 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2571 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2572 -- view of an aliased object whose subtype is constrained.
2574 ---------------------------------
2575 -- Is_Constrained_Aliased_View --
2576 ---------------------------------
2578 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2582 if Is_Entity_Name
(Obj
) then
2585 if Present
(Renamed_Object
(E
)) then
2586 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2588 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2592 return Is_Aliased_View
(Obj
)
2594 (Is_Constrained
(Etype
(Obj
))
2596 (Nkind
(Obj
) = N_Explicit_Dereference
2598 not Object_Type_Has_Constrained_Partial_View
2599 (Typ
=> Base_Type
(Etype
(Obj
)),
2600 Scop
=> Current_Scope
)));
2602 end Is_Constrained_Aliased_View
;
2604 -- Start of processing for Constrained
2607 -- Reference to a parameter where the value is passed as an extra
2608 -- actual, corresponding to the extra formal referenced by the
2609 -- Extra_Constrained field of the corresponding formal. If this
2610 -- is an entry in-parameter, it is replaced by a constant renaming
2611 -- for which Extra_Constrained is never created.
2613 if Present
(Formal_Ent
)
2614 and then Ekind
(Formal_Ent
) /= E_Constant
2615 and then Present
(Extra_Constrained
(Formal_Ent
))
2619 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2621 -- For variables with a Extra_Constrained field, we use the
2622 -- corresponding entity.
2624 elsif Nkind
(Pref
) = N_Identifier
2625 and then Ekind
(Entity
(Pref
)) = E_Variable
2626 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2630 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2632 -- For all other entity names, we can tell at compile time
2634 elsif Is_Entity_Name
(Pref
) then
2636 Ent
: constant Entity_Id
:= Entity
(Pref
);
2640 -- (RM J.4) obsolescent cases
2642 if Is_Type
(Ent
) then
2646 if Is_Private_Type
(Ent
) then
2647 Res
:= not Has_Discriminants
(Ent
)
2648 or else Is_Constrained
(Ent
);
2650 -- It not a private type, must be a generic actual type
2651 -- that corresponded to a private type. We know that this
2652 -- correspondence holds, since otherwise the reference
2653 -- within the generic template would have been illegal.
2656 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2657 Res
:= Is_Constrained
(Ent
);
2663 -- If the prefix is not a variable or is aliased, then
2664 -- definitely true; if it's a formal parameter without an
2665 -- associated extra formal, then treat it as constrained.
2667 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2668 -- constrained in order to set the attribute to True.
2670 elsif not Is_Variable
(Pref
)
2671 or else Present
(Formal_Ent
)
2672 or else (Ada_Version
< Ada_2005
2673 and then Is_Aliased_View
(Pref
))
2674 or else (Ada_Version
>= Ada_2005
2675 and then Is_Constrained_Aliased_View
(Pref
))
2679 -- Variable case, look at type to see if it is constrained.
2680 -- Note that the one case where this is not accurate (the
2681 -- procedure formal case), has been handled above.
2683 -- We use the Underlying_Type here (and below) in case the
2684 -- type is private without discriminants, but the full type
2685 -- has discriminants. This case is illegal, but we generate it
2686 -- internally for passing to the Extra_Constrained parameter.
2689 -- In Ada 2012, test for case of a limited tagged type, in
2690 -- which case the attribute is always required to return
2691 -- True. The underlying type is tested, to make sure we also
2692 -- return True for cases where there is an unconstrained
2693 -- object with an untagged limited partial view which has
2694 -- defaulted discriminants (such objects always produce a
2695 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2697 Res
:= Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2699 (Ada_Version
>= Ada_2012
2700 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2701 and then Is_Limited_Type
(Ptyp
));
2704 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Res
), Loc
));
2707 -- Prefix is not an entity name. These are also cases where we can
2708 -- always tell at compile time by looking at the form and type of the
2709 -- prefix. If an explicit dereference of an object with constrained
2710 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2711 -- underlying type is a limited tagged type, then Constrained is
2712 -- required to always return True (Ada 2012: AI05-0214).
2718 not Is_Variable
(Pref
)
2720 (Nkind
(Pref
) = N_Explicit_Dereference
2722 not Object_Type_Has_Constrained_Partial_View
2723 (Typ
=> Base_Type
(Ptyp
),
2724 Scop
=> Current_Scope
))
2725 or else Is_Constrained
(Underlying_Type
(Ptyp
))
2726 or else (Ada_Version
>= Ada_2012
2727 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2728 and then Is_Limited_Type
(Ptyp
))),
2732 Analyze_And_Resolve
(N
, Standard_Boolean
);
2739 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2740 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2742 when Attribute_Copy_Sign
=>
2743 Expand_Fpt_Attribute_RR
(N
);
2749 -- Transforms 'Count attribute into a call to the Count function
2751 when Attribute_Count
=> Count
: declare
2753 Conctyp
: Entity_Id
;
2755 Entry_Id
: Entity_Id
;
2760 -- If the prefix is a member of an entry family, retrieve both
2761 -- entry name and index. For a simple entry there is no index.
2763 if Nkind
(Pref
) = N_Indexed_Component
then
2764 Entnam
:= Prefix
(Pref
);
2765 Index
:= First
(Expressions
(Pref
));
2771 Entry_Id
:= Entity
(Entnam
);
2773 -- Find the concurrent type in which this attribute is referenced
2774 -- (there had better be one).
2776 Conctyp
:= Current_Scope
;
2777 while not Is_Concurrent_Type
(Conctyp
) loop
2778 Conctyp
:= Scope
(Conctyp
);
2783 if Is_Protected_Type
(Conctyp
) then
2784 case Corresponding_Runtime_Package
(Conctyp
) is
2785 when System_Tasking_Protected_Objects_Entries
=>
2786 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
2789 Make_Function_Call
(Loc
,
2791 Parameter_Associations
=> New_List
(
2793 (Find_Protection_Object
(Current_Scope
), Loc
),
2794 Entry_Index_Expression
2795 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2797 when System_Tasking_Protected_Objects_Single_Entry
=>
2799 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
2802 Make_Function_Call
(Loc
,
2804 Parameter_Associations
=> New_List
(
2806 (Find_Protection_Object
(Current_Scope
), Loc
)));
2809 raise Program_Error
;
2816 Make_Function_Call
(Loc
,
2817 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
2818 Parameter_Associations
=> New_List
(
2819 Entry_Index_Expression
(Loc
,
2820 Entry_Id
, Index
, Scope
(Entry_Id
))));
2823 -- The call returns type Natural but the context is universal integer
2824 -- so any integer type is allowed. The attribute was already resolved
2825 -- so its Etype is the required result type. If the base type of the
2826 -- context type is other than Standard.Integer we put in a conversion
2827 -- to the required type. This can be a normal typed conversion since
2828 -- both input and output types of the conversion are integer types
2830 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2831 Rewrite
(N
, Convert_To
(Typ
, Call
));
2836 Analyze_And_Resolve
(N
, Typ
);
2839 ---------------------
2840 -- Descriptor_Size --
2841 ---------------------
2843 when Attribute_Descriptor_Size
=>
2845 -- Attribute Descriptor_Size is handled by the back end when applied
2846 -- to an unconstrained array type.
2848 if Is_Array_Type
(Ptyp
)
2849 and then not Is_Constrained
(Ptyp
)
2851 Apply_Universal_Integer_Attribute_Checks
(N
);
2853 -- For any other type, the descriptor size is 0 because there is no
2854 -- actual descriptor, but the result is not formally static.
2857 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2859 Set_Is_Static_Expression
(N
, False);
2866 -- This processing is shared by Elab_Spec
2868 -- What we do is to insert the following declarations
2871 -- pragma Import (C, enn, "name___elabb/s");
2873 -- and then the Elab_Body/Spec attribute is replaced by a reference
2874 -- to this defining identifier.
2876 when Attribute_Elab_Body |
2877 Attribute_Elab_Spec
=>
2879 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2880 -- back-end knows how to handle these attributes directly.
2882 if CodePeer_Mode
then
2887 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
2891 procedure Make_Elab_String
(Nod
: Node_Id
);
2892 -- Given Nod, an identifier, or a selected component, put the
2893 -- image into the current string literal, with double underline
2894 -- between components.
2896 ----------------------
2897 -- Make_Elab_String --
2898 ----------------------
2900 procedure Make_Elab_String
(Nod
: Node_Id
) is
2902 if Nkind
(Nod
) = N_Selected_Component
then
2903 Make_Elab_String
(Prefix
(Nod
));
2907 Store_String_Char
('$');
2909 Store_String_Char
('.');
2911 Store_String_Char
('_');
2912 Store_String_Char
('_');
2915 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
2918 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
2919 Get_Name_String
(Chars
(Nod
));
2922 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2923 end Make_Elab_String
;
2925 -- Start of processing for Elab_Body/Elab_Spec
2928 -- First we need to prepare the string literal for the name of
2929 -- the elaboration routine to be referenced.
2932 Make_Elab_String
(Pref
);
2934 if VM_Target
= No_VM
then
2935 Store_String_Chars
("___elab");
2936 Lang
:= Make_Identifier
(Loc
, Name_C
);
2938 Store_String_Chars
("._elab");
2939 Lang
:= Make_Identifier
(Loc
, Name_Ada
);
2942 if Id
= Attribute_Elab_Body
then
2943 Store_String_Char
('b');
2945 Store_String_Char
('s');
2950 Insert_Actions
(N
, New_List
(
2951 Make_Subprogram_Declaration
(Loc
,
2953 Make_Procedure_Specification
(Loc
,
2954 Defining_Unit_Name
=> Ent
)),
2957 Chars
=> Name_Import
,
2958 Pragma_Argument_Associations
=> New_List
(
2959 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
2961 Make_Pragma_Argument_Association
(Loc
,
2962 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
2964 Make_Pragma_Argument_Association
(Loc
,
2965 Expression
=> Make_String_Literal
(Loc
, Str
))))));
2967 Set_Entity
(N
, Ent
);
2968 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
2971 --------------------
2972 -- Elab_Subp_Body --
2973 --------------------
2975 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2976 -- this attribute directly, and if we are not in CodePeer mode it is
2977 -- entirely ignored ???
2979 when Attribute_Elab_Subp_Body
=>
2986 -- Elaborated is always True for preelaborated units, predefined units,
2987 -- pure units and units which have Elaborate_Body pragmas. These units
2988 -- have no elaboration entity.
2990 -- Note: The Elaborated attribute is never passed to the back end
2992 when Attribute_Elaborated
=> Elaborated
: declare
2993 Ent
: constant Entity_Id
:= Entity
(Pref
);
2996 if Present
(Elaboration_Entity
(Ent
)) then
3000 New_Occurrence_Of
(Elaboration_Entity
(Ent
), Loc
),
3002 Make_Integer_Literal
(Loc
, Uint_0
)));
3003 Analyze_And_Resolve
(N
, Typ
);
3005 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3013 when Attribute_Enum_Rep
=> Enum_Rep
:
3015 -- X'Enum_Rep (Y) expands to
3019 -- This is simply a direct conversion from the enumeration type to
3020 -- the target integer type, which is treated by the back end as a
3021 -- normal integer conversion, treating the enumeration type as an
3022 -- integer, which is exactly what we want. We set Conversion_OK to
3023 -- make sure that the analyzer does not complain about what otherwise
3024 -- might be an illegal conversion.
3026 if Is_Non_Empty_List
(Exprs
) then
3028 OK_Convert_To
(Typ
, Relocate_Node
(First
(Exprs
))));
3030 -- X'Enum_Rep where X is an enumeration literal is replaced by
3031 -- the literal value.
3033 elsif Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
then
3035 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Pref
))));
3037 -- If this is a renaming of a literal, recover the representation
3040 elsif Ekind
(Entity
(Pref
)) = E_Constant
3041 and then Present
(Renamed_Object
(Entity
(Pref
)))
3043 Ekind
(Entity
(Renamed_Object
(Entity
(Pref
))))
3044 = E_Enumeration_Literal
3047 Make_Integer_Literal
(Loc
,
3048 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Pref
))))));
3050 -- X'Enum_Rep where X is an object does a direct unchecked conversion
3051 -- of the object value, as described for the type case above.
3055 OK_Convert_To
(Typ
, Relocate_Node
(Pref
)));
3059 Analyze_And_Resolve
(N
, Typ
);
3066 when Attribute_Enum_Val
=> Enum_Val
: declare
3068 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3071 -- X'Enum_Val (Y) expands to
3073 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3076 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3079 Make_Raise_Constraint_Error
(Loc
,
3083 Make_Function_Call
(Loc
,
3085 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3086 Parameter_Associations
=> New_List
(
3087 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3088 New_Occurrence_Of
(Standard_False
, Loc
))),
3090 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3091 Reason
=> CE_Range_Check_Failed
));
3094 Analyze_And_Resolve
(N
, Ptyp
);
3101 -- Transforms 'Exponent into a call to the floating-point attribute
3102 -- function Exponent in Fat_xxx (where xxx is the root type)
3104 when Attribute_Exponent
=>
3105 Expand_Fpt_Attribute_R
(N
);
3111 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3113 when Attribute_External_Tag
=> External_Tag
:
3116 Make_Function_Call
(Loc
,
3117 Name
=> New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3118 Parameter_Associations
=> New_List
(
3119 Make_Attribute_Reference
(Loc
,
3120 Attribute_Name
=> Name_Tag
,
3121 Prefix
=> Prefix
(N
)))));
3123 Analyze_And_Resolve
(N
, Standard_String
);
3130 when Attribute_First
=>
3132 -- If the prefix type is a constrained packed array type which
3133 -- already has a Packed_Array_Impl_Type representation defined, then
3134 -- replace this attribute with a direct reference to 'First of the
3135 -- appropriate index subtype (since otherwise the back end will try
3136 -- to give us the value of 'First for this implementation type).
3138 if Is_Constrained_Packed_Array
(Ptyp
) then
3140 Make_Attribute_Reference
(Loc
,
3141 Attribute_Name
=> Name_First
,
3143 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3144 Analyze_And_Resolve
(N
, Typ
);
3146 -- For access type, apply access check as needed
3148 elsif Is_Access_Type
(Ptyp
) then
3149 Apply_Access_Check
(N
);
3151 -- For scalar type, if low bound is a reference to an entity, just
3152 -- replace with a direct reference. Note that we can only have a
3153 -- reference to a constant entity at this stage, anything else would
3154 -- have already been rewritten.
3156 elsif Is_Scalar_Type
(Ptyp
) then
3158 Lo
: constant Node_Id
:= Type_Low_Bound
(Ptyp
);
3160 if Is_Entity_Name
(Lo
) then
3161 Rewrite
(N
, New_Occurrence_Of
(Entity
(Lo
), Loc
));
3170 -- Compute this if component clause was present, otherwise we leave the
3171 -- computation to be completed in the back-end, since we don't know what
3172 -- layout will be chosen.
3174 when Attribute_First_Bit
=> First_Bit_Attr
: declare
3175 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3178 -- In Ada 2005 (or later) if we have the non-default bit order, then
3179 -- we return the original value as given in the component clause
3180 -- (RM 2005 13.5.2(3/2)).
3182 if Present
(Component_Clause
(CE
))
3183 and then Ada_Version
>= Ada_2005
3184 and then Reverse_Bit_Order
(Scope
(CE
))
3187 Make_Integer_Literal
(Loc
,
3188 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
3189 Analyze_And_Resolve
(N
, Typ
);
3191 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3192 -- rewrite with normalized value if we know it statically.
3194 elsif Known_Static_Component_Bit_Offset
(CE
) then
3196 Make_Integer_Literal
(Loc
,
3197 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
3198 Analyze_And_Resolve
(N
, Typ
);
3200 -- Otherwise left to back end, just do universal integer checks
3203 Apply_Universal_Integer_Attribute_Checks
(N
);
3213 -- fixtype'Fixed_Value (integer-value)
3217 -- fixtype(integer-value)
3219 -- We do all the required analysis of the conversion here, because we do
3220 -- not want this to go through the fixed-point conversion circuits. Note
3221 -- that the back end always treats fixed-point as equivalent to the
3222 -- corresponding integer type anyway.
3224 when Attribute_Fixed_Value
=> Fixed_Value
:
3227 Make_Type_Conversion
(Loc
,
3228 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3229 Expression
=> Relocate_Node
(First
(Exprs
))));
3230 Set_Etype
(N
, Entity
(Pref
));
3233 -- Note: it might appear that a properly analyzed unchecked conversion
3234 -- would be just fine here, but that's not the case, since the full
3235 -- range checks performed by the following call are critical.
3237 Apply_Type_Conversion_Checks
(N
);
3244 -- Transforms 'Floor into a call to the floating-point attribute
3245 -- function Floor in Fat_xxx (where xxx is the root type)
3247 when Attribute_Floor
=>
3248 Expand_Fpt_Attribute_R
(N
);
3254 -- For the fixed-point type Typ:
3260 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3261 -- Universal_Real (Type'Last))
3263 -- Note that we know that the type is a non-static subtype, or Fore
3264 -- would have itself been computed dynamically in Eval_Attribute.
3266 when Attribute_Fore
=> Fore
: begin
3269 Make_Function_Call
(Loc
,
3270 Name
=> New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
3272 Parameter_Associations
=> New_List
(
3273 Convert_To
(Universal_Real
,
3274 Make_Attribute_Reference
(Loc
,
3275 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3276 Attribute_Name
=> Name_First
)),
3278 Convert_To
(Universal_Real
,
3279 Make_Attribute_Reference
(Loc
,
3280 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3281 Attribute_Name
=> Name_Last
))))));
3283 Analyze_And_Resolve
(N
, Typ
);
3290 -- Transforms 'Fraction into a call to the floating-point attribute
3291 -- function Fraction in Fat_xxx (where xxx is the root type)
3293 when Attribute_Fraction
=>
3294 Expand_Fpt_Attribute_R
(N
);
3300 when Attribute_From_Any
=> From_Any
: declare
3301 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3302 Decls
: constant List_Id
:= New_List
;
3305 Build_From_Any_Call
(P_Type
,
3306 Relocate_Node
(First
(Exprs
)),
3308 Insert_Actions
(N
, Decls
);
3309 Analyze_And_Resolve
(N
, P_Type
);
3312 ----------------------
3313 -- Has_Same_Storage --
3314 ----------------------
3316 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3317 Loc
: constant Source_Ptr
:= Sloc
(N
);
3319 X
: constant Node_Id
:= Prefix
(N
);
3320 Y
: constant Node_Id
:= First
(Expressions
(N
));
3323 X_Addr
, Y_Addr
: Node_Id
;
3324 -- Rhe expressions for their addresses
3326 X_Size
, Y_Size
: Node_Id
;
3327 -- Rhe expressions for their sizes
3330 -- The attribute is expanded as:
3332 -- (X'address = Y'address)
3333 -- and then (X'Size = Y'Size)
3335 -- If both arguments have the same Etype the second conjunct can be
3339 Make_Attribute_Reference
(Loc
,
3340 Attribute_Name
=> Name_Address
,
3341 Prefix
=> New_Copy_Tree
(X
));
3344 Make_Attribute_Reference
(Loc
,
3345 Attribute_Name
=> Name_Address
,
3346 Prefix
=> New_Copy_Tree
(Y
));
3349 Make_Attribute_Reference
(Loc
,
3350 Attribute_Name
=> Name_Size
,
3351 Prefix
=> New_Copy_Tree
(X
));
3354 Make_Attribute_Reference
(Loc
,
3355 Attribute_Name
=> Name_Size
,
3356 Prefix
=> New_Copy_Tree
(Y
));
3358 if Etype
(X
) = Etype
(Y
) then
3361 Left_Opnd
=> X_Addr
,
3362 Right_Opnd
=> Y_Addr
)));
3368 Left_Opnd
=> X_Addr
,
3369 Right_Opnd
=> Y_Addr
),
3372 Left_Opnd
=> X_Size
,
3373 Right_Opnd
=> Y_Size
)));
3376 Analyze_And_Resolve
(N
, Standard_Boolean
);
3377 end Has_Same_Storage
;
3383 -- For an exception returns a reference to the exception data:
3384 -- Exception_Id!(Prefix'Reference)
3386 -- For a task it returns a reference to the _task_id component of
3387 -- corresponding record:
3389 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3391 -- in Ada.Task_Identification
3393 when Attribute_Identity
=> Identity
: declare
3394 Id_Kind
: Entity_Id
;
3397 if Ptyp
= Standard_Exception_Type
then
3398 Id_Kind
:= RTE
(RE_Exception_Id
);
3400 if Present
(Renamed_Object
(Entity
(Pref
))) then
3401 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3405 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3407 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3409 -- If the prefix is a task interface, the Task_Id is obtained
3410 -- dynamically through a dispatching call, as for other task
3411 -- attributes applied to interfaces.
3413 if Ada_Version
>= Ada_2005
3414 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3415 and then Is_Interface
(Ptyp
)
3416 and then Is_Task_Interface
(Ptyp
)
3419 Unchecked_Convert_To
(Id_Kind
,
3420 Make_Selected_Component
(Loc
,
3422 New_Copy_Tree
(Pref
),
3424 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))));
3428 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3432 Analyze_And_Resolve
(N
, Id_Kind
);
3439 -- Image attribute is handled in separate unit Exp_Imgv
3441 when Attribute_Image
=>
3442 Exp_Imgv
.Expand_Image_Attribute
(N
);
3448 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3450 when Attribute_Img
=> Img
:
3453 Make_Attribute_Reference
(Loc
,
3454 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3455 Attribute_Name
=> Name_Image
,
3456 Expressions
=> New_List
(Relocate_Node
(Pref
))));
3458 Analyze_And_Resolve
(N
, Standard_String
);
3465 when Attribute_Input
=> Input
: declare
3466 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3467 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3468 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3469 Strm
: constant Node_Id
:= First
(Exprs
);
3477 Cntrl
: Node_Id
:= Empty
;
3478 -- Value for controlling argument in call. Always Empty except in
3479 -- the dispatching (class-wide type) case, where it is a reference
3480 -- to the dummy object initialized to the right internal tag.
3482 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3483 -- The expansion of the attribute reference may generate a call to
3484 -- a user-defined stream subprogram that is frozen by the call. This
3485 -- can lead to access-before-elaboration problem if the reference
3486 -- appears in an object declaration and the subprogram body has not
3487 -- been seen. The freezing of the subprogram requires special code
3488 -- because it appears in an expanded context where expressions do
3489 -- not freeze their constituents.
3491 ------------------------------
3492 -- Freeze_Stream_Subprogram --
3493 ------------------------------
3495 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3496 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3500 -- If this is user-defined subprogram, the corresponding
3501 -- stream function appears as a renaming-as-body, and the
3502 -- user subprogram must be retrieved by tree traversal.
3505 and then Nkind
(Decl
) = N_Subprogram_Declaration
3506 and then Present
(Corresponding_Body
(Decl
))
3508 Bod
:= Corresponding_Body
(Decl
);
3510 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3511 N_Subprogram_Renaming_Declaration
3513 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3516 end Freeze_Stream_Subprogram
;
3518 -- Start of processing for Input
3521 -- If no underlying type, we have an error that will be diagnosed
3522 -- elsewhere, so here we just completely ignore the expansion.
3528 -- Stream operations can appear in user code even if the restriction
3529 -- No_Streams is active (for example, when instantiating a predefined
3530 -- container). In that case rewrite the attribute as a Raise to
3531 -- prevent any run-time use.
3533 if Restriction_Active
(No_Streams
) then
3535 Make_Raise_Program_Error
(Sloc
(N
),
3536 Reason
=> PE_Stream_Operation_Not_Allowed
));
3537 Set_Etype
(N
, B_Type
);
3541 -- If there is a TSS for Input, just call it
3543 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3545 if Present
(Fname
) then
3549 -- If there is a Stream_Convert pragma, use it, we rewrite
3551 -- sourcetyp'Input (stream)
3555 -- sourcetyp (streamread (strmtyp'Input (stream)));
3557 -- where streamread is the given Read function that converts an
3558 -- argument of type strmtyp to type sourcetyp or a type from which
3559 -- it is derived (extra conversion required for the derived case).
3561 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3563 if Present
(Prag
) then
3564 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3565 Rfunc
:= Entity
(Expression
(Arg2
));
3569 Make_Function_Call
(Loc
,
3570 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3571 Parameter_Associations
=> New_List
(
3572 Make_Attribute_Reference
(Loc
,
3575 (Etype
(First_Formal
(Rfunc
)), Loc
),
3576 Attribute_Name
=> Name_Input
,
3577 Expressions
=> Exprs
)))));
3579 Analyze_And_Resolve
(N
, B_Type
);
3584 elsif Is_Elementary_Type
(U_Type
) then
3586 -- A special case arises if we have a defined _Read routine,
3587 -- since in this case we are required to call this routine.
3589 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Read
)) then
3590 Build_Record_Or_Elementary_Input_Function
3591 (Loc
, U_Type
, Decl
, Fname
);
3592 Insert_Action
(N
, Decl
);
3594 -- For normal cases, we call the I_xxx routine directly
3597 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3598 Analyze_And_Resolve
(N
, P_Type
);
3604 elsif Is_Array_Type
(U_Type
) then
3605 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3606 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3608 -- Dispatching case with class-wide type
3610 elsif Is_Class_Wide_Type
(P_Type
) then
3612 -- No need to do anything else compiling under restriction
3613 -- No_Dispatching_Calls. During the semantic analysis we
3614 -- already notified such violation.
3616 if Restriction_Active
(No_Dispatching_Calls
) then
3621 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3625 -- Read the internal tag (RM 13.13.2(34)) and use it to
3626 -- initialize a dummy tag value:
3628 -- Descendant_Tag (String'Input (Strm), P_Type);
3630 -- This value is used only to provide a controlling
3631 -- argument for the eventual _Input call. Descendant_Tag is
3632 -- called rather than Internal_Tag to ensure that we have a
3633 -- tag for a type that is descended from the prefix type and
3634 -- declared at the same accessibility level (the exception
3635 -- Tag_Error will be raised otherwise). The level check is
3636 -- required for Ada 2005 because tagged types can be
3637 -- extended in nested scopes (AI-344).
3639 -- Note: we used to generate an explicit declaration of a
3640 -- constant Ada.Tags.Tag object, and use an occurrence of
3641 -- this constant in Cntrl, but this caused a secondary stack
3645 Make_Function_Call
(Loc
,
3647 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3648 Parameter_Associations
=> New_List
(
3649 Make_Attribute_Reference
(Loc
,
3651 New_Occurrence_Of
(Standard_String
, Loc
),
3652 Attribute_Name
=> Name_Input
,
3653 Expressions
=> New_List
(
3654 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
3655 Make_Attribute_Reference
(Loc
,
3656 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
3657 Attribute_Name
=> Name_Tag
)));
3658 Set_Etype
(Expr
, RTE
(RE_Tag
));
3660 -- Now we need to get the entity for the call, and construct
3661 -- a function call node, where we preset a reference to Dnn
3662 -- as the controlling argument (doing an unchecked convert
3663 -- to the class-wide tagged type to make it look like a real
3666 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3667 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
3668 Set_Etype
(Cntrl
, P_Type
);
3669 Set_Parent
(Cntrl
, N
);
3672 -- For tagged types, use the primitive Input function
3674 elsif Is_Tagged_Type
(U_Type
) then
3675 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3677 -- All other record type cases, including protected records. The
3678 -- latter only arise for expander generated code for handling
3679 -- shared passive partition access.
3683 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3685 -- Ada 2005 (AI-216): Program_Error is raised executing default
3686 -- implementation of the Input attribute of an unchecked union
3687 -- type if the type lacks default discriminant values.
3689 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3690 and then No
(Discriminant_Constraint
(U_Type
))
3693 Make_Raise_Program_Error
(Loc
,
3694 Reason
=> PE_Unchecked_Union_Restriction
));
3699 -- Build the type's Input function, passing the subtype rather
3700 -- than its base type, because checks are needed in the case of
3701 -- constrained discriminants (see Ada 2012 AI05-0192).
3703 Build_Record_Or_Elementary_Input_Function
3704 (Loc
, U_Type
, Decl
, Fname
);
3705 Insert_Action
(N
, Decl
);
3707 if Nkind
(Parent
(N
)) = N_Object_Declaration
3708 and then Is_Record_Type
(U_Type
)
3710 -- The stream function may contain calls to user-defined
3711 -- Read procedures for individual components.
3718 Comp
:= First_Component
(U_Type
);
3719 while Present
(Comp
) loop
3721 Find_Stream_Subprogram
3722 (Etype
(Comp
), TSS_Stream_Read
);
3724 if Present
(Func
) then
3725 Freeze_Stream_Subprogram
(Func
);
3728 Next_Component
(Comp
);
3735 -- If we fall through, Fname is the function to be called. The result
3736 -- is obtained by calling the appropriate function, then converting
3737 -- the result. The conversion does a subtype check.
3740 Make_Function_Call
(Loc
,
3741 Name
=> New_Occurrence_Of
(Fname
, Loc
),
3742 Parameter_Associations
=> New_List
(
3743 Relocate_Node
(Strm
)));
3745 Set_Controlling_Argument
(Call
, Cntrl
);
3746 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
3747 Analyze_And_Resolve
(N
, P_Type
);
3749 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
3750 Freeze_Stream_Subprogram
(Fname
);
3760 -- inttype'Fixed_Value (fixed-value)
3764 -- inttype(integer-value))
3766 -- we do all the required analysis of the conversion here, because we do
3767 -- not want this to go through the fixed-point conversion circuits. Note
3768 -- that the back end always treats fixed-point as equivalent to the
3769 -- corresponding integer type anyway.
3771 when Attribute_Integer_Value
=> Integer_Value
:
3774 Make_Type_Conversion
(Loc
,
3775 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3776 Expression
=> Relocate_Node
(First
(Exprs
))));
3777 Set_Etype
(N
, Entity
(Pref
));
3780 -- Note: it might appear that a properly analyzed unchecked conversion
3781 -- would be just fine here, but that's not the case, since the full
3782 -- range checks performed by the following call are critical.
3784 Apply_Type_Conversion_Checks
(N
);
3791 when Attribute_Invalid_Value
=>
3792 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
3798 when Attribute_Last
=>
3800 -- If the prefix type is a constrained packed array type which
3801 -- already has a Packed_Array_Impl_Type representation defined, then
3802 -- replace this attribute with a direct reference to 'Last of the
3803 -- appropriate index subtype (since otherwise the back end will try
3804 -- to give us the value of 'Last for this implementation type).
3806 if Is_Constrained_Packed_Array
(Ptyp
) then
3808 Make_Attribute_Reference
(Loc
,
3809 Attribute_Name
=> Name_Last
,
3810 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3811 Analyze_And_Resolve
(N
, Typ
);
3813 -- For access type, apply access check as needed
3815 elsif Is_Access_Type
(Ptyp
) then
3816 Apply_Access_Check
(N
);
3818 -- For scalar type, if low bound is a reference to an entity, just
3819 -- replace with a direct reference. Note that we can only have a
3820 -- reference to a constant entity at this stage, anything else would
3821 -- have already been rewritten.
3823 elsif Is_Scalar_Type
(Ptyp
) then
3825 Hi
: constant Node_Id
:= Type_High_Bound
(Ptyp
);
3827 if Is_Entity_Name
(Hi
) then
3828 Rewrite
(N
, New_Occurrence_Of
(Entity
(Hi
), Loc
));
3837 -- We compute this if a component clause was present, otherwise we leave
3838 -- the computation up to the back end, since we don't know what layout
3841 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
3842 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3845 -- In Ada 2005 (or later) if we have the non-default bit order, then
3846 -- we return the original value as given in the component clause
3847 -- (RM 2005 13.5.2(3/2)).
3849 if Present
(Component_Clause
(CE
))
3850 and then Ada_Version
>= Ada_2005
3851 and then Reverse_Bit_Order
(Scope
(CE
))
3854 Make_Integer_Literal
(Loc
,
3855 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
3856 Analyze_And_Resolve
(N
, Typ
);
3858 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3859 -- rewrite with normalized value if we know it statically.
3861 elsif Known_Static_Component_Bit_Offset
(CE
)
3862 and then Known_Static_Esize
(CE
)
3865 Make_Integer_Literal
(Loc
,
3866 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
3868 Analyze_And_Resolve
(N
, Typ
);
3870 -- Otherwise leave to back end, just apply universal integer checks
3873 Apply_Universal_Integer_Attribute_Checks
(N
);
3881 -- Transforms 'Leading_Part into a call to the floating-point attribute
3882 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3884 -- Note: strictly, we should generate special case code to deal with
3885 -- absurdly large positive arguments (greater than Integer'Last), which
3886 -- result in returning the first argument unchanged, but it hardly seems
3887 -- worth the effort. We raise constraint error for absurdly negative
3888 -- arguments which is fine.
3890 when Attribute_Leading_Part
=>
3891 Expand_Fpt_Attribute_RI
(N
);
3897 when Attribute_Length
=> Length
: declare
3902 -- Processing for packed array types
3904 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
3905 Ityp
:= Get_Index_Subtype
(N
);
3907 -- If the index type, Ityp, is an enumeration type with holes,
3908 -- then we calculate X'Length explicitly using
3911 -- (0, Ityp'Pos (X'Last (N)) -
3912 -- Ityp'Pos (X'First (N)) + 1);
3914 -- Since the bounds in the template are the representation values
3915 -- and the back end would get the wrong value.
3917 if Is_Enumeration_Type
(Ityp
)
3918 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
3923 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
3927 Make_Attribute_Reference
(Loc
,
3928 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3929 Attribute_Name
=> Name_Max
,
3930 Expressions
=> New_List
3931 (Make_Integer_Literal
(Loc
, 0),
3935 Make_Op_Subtract
(Loc
,
3937 Make_Attribute_Reference
(Loc
,
3938 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3939 Attribute_Name
=> Name_Pos
,
3941 Expressions
=> New_List
(
3942 Make_Attribute_Reference
(Loc
,
3943 Prefix
=> Duplicate_Subexpr
(Pref
),
3944 Attribute_Name
=> Name_Last
,
3945 Expressions
=> New_List
(
3946 Make_Integer_Literal
(Loc
, Xnum
))))),
3949 Make_Attribute_Reference
(Loc
,
3950 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3951 Attribute_Name
=> Name_Pos
,
3953 Expressions
=> New_List
(
3954 Make_Attribute_Reference
(Loc
,
3956 Duplicate_Subexpr_No_Checks
(Pref
),
3957 Attribute_Name
=> Name_First
,
3958 Expressions
=> New_List
(
3959 Make_Integer_Literal
(Loc
, Xnum
)))))),
3961 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
3963 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
3966 -- If the prefix type is a constrained packed array type which
3967 -- already has a Packed_Array_Impl_Type representation defined,
3968 -- then replace this attribute with a reference to 'Range_Length
3969 -- of the appropriate index subtype (since otherwise the
3970 -- back end will try to give us the value of 'Length for
3971 -- this implementation type).s
3973 elsif Is_Constrained
(Ptyp
) then
3975 Make_Attribute_Reference
(Loc
,
3976 Attribute_Name
=> Name_Range_Length
,
3977 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
3978 Analyze_And_Resolve
(N
, Typ
);
3983 elsif Is_Access_Type
(Ptyp
) then
3984 Apply_Access_Check
(N
);
3986 -- If the designated type is a packed array type, then we convert
3987 -- the reference to:
3990 -- xtyp'Pos (Pref'Last (Expr)) -
3991 -- xtyp'Pos (Pref'First (Expr)));
3993 -- This is a bit complex, but it is the easiest thing to do that
3994 -- works in all cases including enum types with holes xtyp here
3995 -- is the appropriate index type.
3998 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4002 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
4003 Xtyp
:= Get_Index_Subtype
(N
);
4006 Make_Attribute_Reference
(Loc
,
4007 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4008 Attribute_Name
=> Name_Max
,
4009 Expressions
=> New_List
(
4010 Make_Integer_Literal
(Loc
, 0),
4013 Make_Integer_Literal
(Loc
, 1),
4014 Make_Op_Subtract
(Loc
,
4016 Make_Attribute_Reference
(Loc
,
4017 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4018 Attribute_Name
=> Name_Pos
,
4019 Expressions
=> New_List
(
4020 Make_Attribute_Reference
(Loc
,
4021 Prefix
=> Duplicate_Subexpr
(Pref
),
4022 Attribute_Name
=> Name_Last
,
4024 New_Copy_List
(Exprs
)))),
4027 Make_Attribute_Reference
(Loc
,
4028 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4029 Attribute_Name
=> Name_Pos
,
4030 Expressions
=> New_List
(
4031 Make_Attribute_Reference
(Loc
,
4033 Duplicate_Subexpr_No_Checks
(Pref
),
4034 Attribute_Name
=> Name_First
,
4036 New_Copy_List
(Exprs
)))))))));
4038 Analyze_And_Resolve
(N
, Typ
);
4042 -- Otherwise leave it to the back end
4045 Apply_Universal_Integer_Attribute_Checks
(N
);
4049 -- Attribute Loop_Entry is replaced with a reference to a constant value
4050 -- which captures the prefix at the entry point of the related loop. The
4051 -- loop itself may be transformed into a conditional block.
4053 when Attribute_Loop_Entry
=>
4054 Expand_Loop_Entry_Attribute
(N
);
4060 -- Transforms 'Machine into a call to the floating-point attribute
4061 -- function Machine in Fat_xxx (where xxx is the root type).
4062 -- Expansion is avoided for cases the back end can handle directly.
4064 when Attribute_Machine
=>
4065 if not Is_Inline_Floating_Point_Attribute
(N
) then
4066 Expand_Fpt_Attribute_R
(N
);
4069 ----------------------
4070 -- Machine_Rounding --
4071 ----------------------
4073 -- Transforms 'Machine_Rounding into a call to the floating-point
4074 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4075 -- type). Expansion is avoided for cases the back end can handle
4078 when Attribute_Machine_Rounding
=>
4079 if not Is_Inline_Floating_Point_Attribute
(N
) then
4080 Expand_Fpt_Attribute_R
(N
);
4087 -- Machine_Size is equivalent to Object_Size, so transform it into
4088 -- Object_Size and that way the back end never sees Machine_Size.
4090 when Attribute_Machine_Size
=>
4092 Make_Attribute_Reference
(Loc
,
4093 Prefix
=> Prefix
(N
),
4094 Attribute_Name
=> Name_Object_Size
));
4096 Analyze_And_Resolve
(N
, Typ
);
4102 -- The only case that can get this far is the dynamic case of the old
4103 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4110 -- ityp (System.Mantissa.Mantissa_Value
4111 -- (Integer'Integer_Value (typ'First),
4112 -- Integer'Integer_Value (typ'Last)));
4114 when Attribute_Mantissa
=> Mantissa
: begin
4117 Make_Function_Call
(Loc
,
4118 Name
=> New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4120 Parameter_Associations
=> New_List
(
4122 Make_Attribute_Reference
(Loc
,
4123 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4124 Attribute_Name
=> Name_Integer_Value
,
4125 Expressions
=> New_List
(
4127 Make_Attribute_Reference
(Loc
,
4128 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4129 Attribute_Name
=> Name_First
))),
4131 Make_Attribute_Reference
(Loc
,
4132 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4133 Attribute_Name
=> Name_Integer_Value
,
4134 Expressions
=> New_List
(
4136 Make_Attribute_Reference
(Loc
,
4137 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4138 Attribute_Name
=> Name_Last
)))))));
4140 Analyze_And_Resolve
(N
, Typ
);
4147 when Attribute_Max
=>
4148 Expand_Min_Max_Attribute
(N
);
4150 ----------------------------------
4151 -- Max_Size_In_Storage_Elements --
4152 ----------------------------------
4154 when Attribute_Max_Size_In_Storage_Elements
=> declare
4155 Typ
: constant Entity_Id
:= Etype
(N
);
4158 Conversion_Added
: Boolean := False;
4159 -- A flag which tracks whether the original attribute has been
4160 -- wrapped inside a type conversion.
4163 -- If the prefix is X'Class, we transform it into a direct reference
4164 -- to the class-wide type, because the back end must not see a 'Class
4165 -- reference. See also 'Size.
4167 if Is_Entity_Name
(Pref
)
4168 and then Is_Class_Wide_Type
(Entity
(Pref
))
4170 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4174 Apply_Universal_Integer_Attribute_Checks
(N
);
4176 -- The universal integer check may sometimes add a type conversion,
4177 -- retrieve the original attribute reference from the expression.
4181 if Nkind
(Attr
) = N_Type_Conversion
then
4182 Attr
:= Expression
(Attr
);
4183 Conversion_Added
:= True;
4186 pragma Assert
(Nkind
(Attr
) = N_Attribute_Reference
);
4188 -- Heap-allocated controlled objects contain two extra pointers which
4189 -- are not part of the actual type. Transform the attribute reference
4190 -- into a runtime expression to add the size of the hidden header.
4192 -- Do not perform this expansion on .NET/JVM targets because the
4193 -- two pointers are already present in the type.
4195 if VM_Target
= No_VM
4196 and then Needs_Finalization
(Ptyp
)
4197 and then not Header_Size_Added
(Attr
)
4199 Set_Header_Size_Added
(Attr
);
4202 -- P'Max_Size_In_Storage_Elements +
4203 -- Universal_Integer
4204 -- (Header_Size_With_Padding (Ptyp'Alignment))
4208 Left_Opnd
=> Relocate_Node
(Attr
),
4210 Convert_To
(Universal_Integer
,
4211 Make_Function_Call
(Loc
,
4214 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4216 Parameter_Associations
=> New_List
(
4217 Make_Attribute_Reference
(Loc
,
4219 New_Occurrence_Of
(Ptyp
, Loc
),
4220 Attribute_Name
=> Name_Alignment
))))));
4222 -- Add a conversion to the target type
4224 if not Conversion_Added
then
4226 Make_Type_Conversion
(Loc
,
4227 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4228 Expression
=> Relocate_Node
(Attr
)));
4236 --------------------
4237 -- Mechanism_Code --
4238 --------------------
4240 when Attribute_Mechanism_Code
=>
4242 -- We must replace the prefix i the renamed case
4244 if Is_Entity_Name
(Pref
)
4245 and then Present
(Alias
(Entity
(Pref
)))
4247 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4254 when Attribute_Min
=>
4255 Expand_Min_Max_Attribute
(N
);
4261 when Attribute_Mod
=> Mod_Case
: declare
4262 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4263 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
4264 Modv
: constant Uint
:= Modulus
(Btyp
);
4268 -- This is not so simple. The issue is what type to use for the
4269 -- computation of the modular value.
4271 -- The easy case is when the modulus value is within the bounds
4272 -- of the signed integer type of the argument. In this case we can
4273 -- just do the computation in that signed integer type, and then
4274 -- do an ordinary conversion to the target type.
4276 if Modv
<= Expr_Value
(Hi
) then
4281 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4283 -- Here we know that the modulus is larger than type'Last of the
4284 -- integer type. There are two cases to consider:
4286 -- a) The integer value is non-negative. In this case, it is
4287 -- returned as the result (since it is less than the modulus).
4289 -- b) The integer value is negative. In this case, we know that the
4290 -- result is modulus + value, where the value might be as small as
4291 -- -modulus. The trouble is what type do we use to do the subtract.
4292 -- No type will do, since modulus can be as big as 2**64, and no
4293 -- integer type accommodates this value. Let's do bit of algebra
4296 -- = modulus - (-value)
4297 -- = (modulus - 1) - (-value - 1)
4299 -- Now modulus - 1 is certainly in range of the modular type.
4300 -- -value is in the range 1 .. modulus, so -value -1 is in the
4301 -- range 0 .. modulus-1 which is in range of the modular type.
4302 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4303 -- which we can compute using the integer base type.
4305 -- Once this is done we analyze the if expression without range
4306 -- checks, because we know everything is in range, and we want
4307 -- to prevent spurious warnings on either branch.
4311 Make_If_Expression
(Loc
,
4312 Expressions
=> New_List
(
4314 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4315 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4318 Duplicate_Subexpr_No_Checks
(Arg
)),
4320 Make_Op_Subtract
(Loc
,
4322 Make_Integer_Literal
(Loc
,
4323 Intval
=> Modv
- 1),
4329 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4331 Make_Integer_Literal
(Loc
,
4332 Intval
=> 1))))))));
4336 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4343 -- Transforms 'Model into a call to the floating-point attribute
4344 -- function Model in Fat_xxx (where xxx is the root type).
4345 -- Expansion is avoided for cases the back end can handle directly.
4347 when Attribute_Model
=>
4348 if not Is_Inline_Floating_Point_Attribute
(N
) then
4349 Expand_Fpt_Attribute_R
(N
);
4356 -- The processing for Object_Size shares the processing for Size
4362 when Attribute_Old
=> Old
: declare
4363 Typ
: constant Entity_Id
:= Etype
(N
);
4364 CW_Temp
: Entity_Id
;
4370 -- Climb the parent chain looking for subprogram _Postconditions
4373 while Present
(Subp
) loop
4374 exit when Nkind
(Subp
) = N_Subprogram_Body
4375 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
4377 -- If assertions are disabled, no need to create the declaration
4378 -- that preserves the value. The postcondition pragma in which
4379 -- 'Old appears will be checked or disabled according to the
4380 -- current policy in effect.
4382 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
4386 Subp
:= Parent
(Subp
);
4389 -- 'Old can only appear in a postcondition, the generated body of
4390 -- _Postconditions must be in the tree.
4392 pragma Assert
(Present
(Subp
));
4394 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
4396 -- Set the entity kind now in order to mark the temporary as a
4397 -- handler of attribute 'Old's prefix.
4399 Set_Ekind
(Temp
, E_Constant
);
4400 Set_Stores_Attribute_Old_Prefix
(Temp
);
4402 -- Push the scope of the related subprogram where _Postcondition
4403 -- resides as this ensures that the object will be analyzed in the
4406 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4408 -- Preserve the tag of the prefix by offering a specific view of the
4409 -- class-wide version of the prefix.
4411 if Is_Tagged_Type
(Typ
) then
4414 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4416 CW_Temp
:= Make_Temporary
(Loc
, 'T');
4417 CW_Typ
:= Class_Wide_Type
(Typ
);
4419 Insert_Before_And_Analyze
(Subp
,
4420 Make_Object_Declaration
(Loc
,
4421 Defining_Identifier
=> CW_Temp
,
4422 Constant_Present
=> True,
4423 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
4425 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
4428 -- Temp : Typ renames Typ (CW_Temp);
4430 Insert_Before_And_Analyze
(Subp
,
4431 Make_Object_Renaming_Declaration
(Loc
,
4432 Defining_Identifier
=> Temp
,
4433 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
4435 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
4441 -- Temp : constant Typ := Pref;
4443 Insert_Before_And_Analyze
(Subp
,
4444 Make_Object_Declaration
(Loc
,
4445 Defining_Identifier
=> Temp
,
4446 Constant_Present
=> True,
4447 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
4448 Expression
=> Relocate_Node
(Pref
)));
4453 -- Ensure that the prefix of attribute 'Old is valid. The check must
4454 -- be inserted after the expansion of the attribute has taken place
4455 -- to reflect the new placement of the prefix.
4457 if Validity_Checks_On
and then Validity_Check_Operands
then
4458 Ensure_Valid
(Pref
);
4461 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4464 ----------------------
4465 -- Overlaps_Storage --
4466 ----------------------
4468 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4469 Loc
: constant Source_Ptr
:= Sloc
(N
);
4471 X
: constant Node_Id
:= Prefix
(N
);
4472 Y
: constant Node_Id
:= First
(Expressions
(N
));
4475 X_Addr
, Y_Addr
: Node_Id
;
4476 -- the expressions for their integer addresses
4478 X_Size
, Y_Size
: Node_Id
;
4479 -- the expressions for their sizes
4484 -- Attribute expands into:
4486 -- if X'Address < Y'address then
4487 -- (X'address + X'Size - 1) >= Y'address
4489 -- (Y'address + Y'size - 1) >= X'Address
4492 -- with the proper address operations. We convert addresses to
4493 -- integer addresses to use predefined arithmetic. The size is
4494 -- expressed in storage units.
4497 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4498 Make_Attribute_Reference
(Loc
,
4499 Attribute_Name
=> Name_Address
,
4500 Prefix
=> New_Copy_Tree
(X
)));
4503 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4504 Make_Attribute_Reference
(Loc
,
4505 Attribute_Name
=> Name_Address
,
4506 Prefix
=> New_Copy_Tree
(Y
)));
4509 Make_Op_Divide
(Loc
,
4511 Make_Attribute_Reference
(Loc
,
4512 Attribute_Name
=> Name_Size
,
4513 Prefix
=> New_Copy_Tree
(X
)),
4515 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4518 Make_Op_Divide
(Loc
,
4520 Make_Attribute_Reference
(Loc
,
4521 Attribute_Name
=> Name_Size
,
4522 Prefix
=> New_Copy_Tree
(Y
)),
4524 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4528 Left_Opnd
=> X_Addr
,
4529 Right_Opnd
=> Y_Addr
);
4532 Make_If_Expression
(Loc
,
4539 Left_Opnd
=> X_Addr
,
4541 Make_Op_Subtract
(Loc
,
4542 Left_Opnd
=> X_Size
,
4543 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4544 Right_Opnd
=> Y_Addr
),
4548 Left_Opnd
=> Y_Addr
,
4550 Make_Op_Subtract
(Loc
,
4551 Left_Opnd
=> Y_Size
,
4552 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4553 Right_Opnd
=> X_Addr
))));
4555 Analyze_And_Resolve
(N
, Standard_Boolean
);
4556 end Overlaps_Storage
;
4562 when Attribute_Output
=> Output
: declare
4563 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4564 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4572 -- If no underlying type, we have an error that will be diagnosed
4573 -- elsewhere, so here we just completely ignore the expansion.
4579 -- Stream operations can appear in user code even if the restriction
4580 -- No_Streams is active (for example, when instantiating a predefined
4581 -- container). In that case rewrite the attribute as a Raise to
4582 -- prevent any run-time use.
4584 if Restriction_Active
(No_Streams
) then
4586 Make_Raise_Program_Error
(Sloc
(N
),
4587 Reason
=> PE_Stream_Operation_Not_Allowed
));
4588 Set_Etype
(N
, Standard_Void_Type
);
4592 -- If TSS for Output is present, just call it
4594 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
4596 if Present
(Pname
) then
4600 -- If there is a Stream_Convert pragma, use it, we rewrite
4602 -- sourcetyp'Output (stream, Item)
4606 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4608 -- where strmwrite is the given Write function that converts an
4609 -- argument of type sourcetyp or a type acctyp, from which it is
4610 -- derived to type strmtyp. The conversion to acttyp is required
4611 -- for the derived case.
4613 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4615 if Present
(Prag
) then
4617 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4618 Wfunc
:= Entity
(Expression
(Arg3
));
4621 Make_Attribute_Reference
(Loc
,
4622 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4623 Attribute_Name
=> Name_Output
,
4624 Expressions
=> New_List
(
4625 Relocate_Node
(First
(Exprs
)),
4626 Make_Function_Call
(Loc
,
4627 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4628 Parameter_Associations
=> New_List
(
4629 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4630 Relocate_Node
(Next
(First
(Exprs
)))))))));
4635 -- For elementary types, we call the W_xxx routine directly. Note
4636 -- that the effect of Write and Output is identical for the case
4637 -- of an elementary type (there are no discriminants or bounds).
4639 elsif Is_Elementary_Type
(U_Type
) then
4641 -- A special case arises if we have a defined _Write routine,
4642 -- since in this case we are required to call this routine.
4644 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Write
)) then
4645 Build_Record_Or_Elementary_Output_Procedure
4646 (Loc
, U_Type
, Decl
, Pname
);
4647 Insert_Action
(N
, Decl
);
4649 -- For normal cases, we call the W_xxx routine directly
4652 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4659 elsif Is_Array_Type
(U_Type
) then
4660 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4661 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4663 -- Class-wide case, first output external tag, then dispatch
4664 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4666 elsif Is_Class_Wide_Type
(P_Type
) then
4668 -- No need to do anything else compiling under restriction
4669 -- No_Dispatching_Calls. During the semantic analysis we
4670 -- already notified such violation.
4672 if Restriction_Active
(No_Dispatching_Calls
) then
4677 Strm
: constant Node_Id
:= First
(Exprs
);
4678 Item
: constant Node_Id
:= Next
(Strm
);
4681 -- Ada 2005 (AI-344): Check that the accessibility level
4682 -- of the type of the output object is not deeper than
4683 -- that of the attribute's prefix type.
4685 -- if Get_Access_Level (Item'Tag)
4686 -- /= Get_Access_Level (P_Type'Tag)
4691 -- String'Output (Strm, External_Tag (Item'Tag));
4693 -- We cannot figure out a practical way to implement this
4694 -- accessibility check on virtual machines, so we omit it.
4696 if Ada_Version
>= Ada_2005
4697 and then Tagged_Type_Expansion
4700 Make_Implicit_If_Statement
(N
,
4704 Build_Get_Access_Level
(Loc
,
4705 Make_Attribute_Reference
(Loc
,
4708 Duplicate_Subexpr
(Item
,
4710 Attribute_Name
=> Name_Tag
)),
4713 Make_Integer_Literal
(Loc
,
4714 Type_Access_Level
(P_Type
))),
4717 New_List
(Make_Raise_Statement
(Loc
,
4719 RTE
(RE_Tag_Error
), Loc
)))));
4723 Make_Attribute_Reference
(Loc
,
4724 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
4725 Attribute_Name
=> Name_Output
,
4726 Expressions
=> New_List
(
4727 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
4728 Make_Function_Call
(Loc
,
4730 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
4731 Parameter_Associations
=> New_List
(
4732 Make_Attribute_Reference
(Loc
,
4735 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
4736 Attribute_Name
=> Name_Tag
))))));
4739 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4741 -- Tagged type case, use the primitive Output function
4743 elsif Is_Tagged_Type
(U_Type
) then
4744 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4746 -- All other record type cases, including protected records.
4747 -- The latter only arise for expander generated code for
4748 -- handling shared passive partition access.
4752 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4754 -- Ada 2005 (AI-216): Program_Error is raised when executing
4755 -- the default implementation of the Output attribute of an
4756 -- unchecked union type if the type lacks default discriminant
4759 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4760 and then No
(Discriminant_Constraint
(U_Type
))
4763 Make_Raise_Program_Error
(Loc
,
4764 Reason
=> PE_Unchecked_Union_Restriction
));
4769 Build_Record_Or_Elementary_Output_Procedure
4770 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
4771 Insert_Action
(N
, Decl
);
4775 -- If we fall through, Pname is the name of the procedure to call
4777 Rewrite_Stream_Proc_Call
(Pname
);
4784 -- For enumeration types with a standard representation, Pos is
4785 -- handled by the back end.
4787 -- For enumeration types, with a non-standard representation we generate
4788 -- a call to the _Rep_To_Pos function created when the type was frozen.
4789 -- The call has the form
4791 -- _rep_to_pos (expr, flag)
4793 -- The parameter flag is True if range checks are enabled, causing
4794 -- Program_Error to be raised if the expression has an invalid
4795 -- representation, and False if range checks are suppressed.
4797 -- For integer types, Pos is equivalent to a simple integer
4798 -- conversion and we rewrite it as such
4800 when Attribute_Pos
=> Pos
:
4802 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
4805 -- Deal with zero/non-zero boolean values
4807 if Is_Boolean_Type
(Etyp
) then
4808 Adjust_Condition
(First
(Exprs
));
4809 Etyp
:= Standard_Boolean
;
4810 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
4813 -- Case of enumeration type
4815 if Is_Enumeration_Type
(Etyp
) then
4817 -- Non-standard enumeration type (generate call)
4819 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
4820 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
4823 Make_Function_Call
(Loc
,
4825 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4826 Parameter_Associations
=> Exprs
)));
4828 Analyze_And_Resolve
(N
, Typ
);
4830 -- Standard enumeration type (do universal integer check)
4833 Apply_Universal_Integer_Attribute_Checks
(N
);
4836 -- Deal with integer types (replace by conversion)
4838 elsif Is_Integer_Type
(Etyp
) then
4839 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
4840 Analyze_And_Resolve
(N
, Typ
);
4849 -- We compute this if a component clause was present, otherwise we leave
4850 -- the computation up to the back end, since we don't know what layout
4853 when Attribute_Position
=> Position_Attr
:
4855 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4858 if Present
(Component_Clause
(CE
)) then
4860 -- In Ada 2005 (or later) if we have the non-default bit order,
4861 -- then we return the original value as given in the component
4862 -- clause (RM 2005 13.5.2(2/2)).
4864 if Ada_Version
>= Ada_2005
4865 and then Reverse_Bit_Order
(Scope
(CE
))
4868 Make_Integer_Literal
(Loc
,
4869 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
4871 -- Otherwise (Ada 83 or 95, or default bit order specified in
4872 -- later Ada version), return the normalized value.
4876 Make_Integer_Literal
(Loc
,
4877 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
4880 Analyze_And_Resolve
(N
, Typ
);
4882 -- If back end is doing things, just apply universal integer checks
4885 Apply_Universal_Integer_Attribute_Checks
(N
);
4893 -- 1. Deal with enumeration types with holes.
4894 -- 2. For floating-point, generate call to attribute function.
4895 -- 3. For other cases, deal with constraint checking.
4897 when Attribute_Pred
=> Pred
:
4899 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
4903 -- For enumeration types with non-standard representations, we
4904 -- expand typ'Pred (x) into
4906 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4908 -- If the representation is contiguous, we compute instead
4909 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4910 -- The conversion function Enum_Pos_To_Rep is defined on the
4911 -- base type, not the subtype, so we have to use the base type
4912 -- explicitly for this and other enumeration attributes.
4914 if Is_Enumeration_Type
(Ptyp
)
4915 and then Present
(Enum_Pos_To_Rep
(Etyp
))
4917 if Has_Contiguous_Rep
(Etyp
) then
4919 Unchecked_Convert_To
(Ptyp
,
4922 Make_Integer_Literal
(Loc
,
4923 Enumeration_Rep
(First_Literal
(Ptyp
))),
4925 Make_Function_Call
(Loc
,
4928 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4930 Parameter_Associations
=>
4932 Unchecked_Convert_To
(Ptyp
,
4933 Make_Op_Subtract
(Loc
,
4935 Unchecked_Convert_To
(Standard_Integer
,
4936 Relocate_Node
(First
(Exprs
))),
4938 Make_Integer_Literal
(Loc
, 1))),
4939 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
4942 -- Add Boolean parameter True, to request program errror if
4943 -- we have a bad representation on our hands. If checks are
4944 -- suppressed, then add False instead
4946 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
4948 Make_Indexed_Component
(Loc
,
4951 (Enum_Pos_To_Rep
(Etyp
), Loc
),
4952 Expressions
=> New_List
(
4953 Make_Op_Subtract
(Loc
,
4955 Make_Function_Call
(Loc
,
4958 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4959 Parameter_Associations
=> Exprs
),
4960 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4963 Analyze_And_Resolve
(N
, Typ
);
4965 -- For floating-point, we transform 'Pred into a call to the Pred
4966 -- floating-point attribute function in Fat_xxx (xxx is root type).
4967 -- Note that this function takes care of the overflow case.
4969 elsif Is_Floating_Point_Type
(Ptyp
) then
4970 Expand_Fpt_Attribute_R
(N
);
4971 Analyze_And_Resolve
(N
, Typ
);
4973 -- For modular types, nothing to do (no overflow, since wraps)
4975 elsif Is_Modular_Integer_Type
(Ptyp
) then
4978 -- For other types, if argument is marked as needing a range check or
4979 -- overflow checking is enabled, we must generate a check.
4981 elsif not Overflow_Checks_Suppressed
(Ptyp
)
4982 or else Do_Range_Check
(First
(Exprs
))
4984 Set_Do_Range_Check
(First
(Exprs
), False);
4985 Expand_Pred_Succ_Attribute
(N
);
4993 -- Ada 2005 (AI-327): Dynamic ceiling priorities
4995 -- We rewrite X'Priority as the following run-time call:
4997 -- Get_Ceiling (X._Object)
4999 -- Note that although X'Priority is notionally an object, it is quite
5000 -- deliberately not defined as an aliased object in the RM. This means
5001 -- that it works fine to rewrite it as a call, without having to worry
5002 -- about complications that would other arise from X'Priority'Access,
5003 -- which is illegal, because of the lack of aliasing.
5005 when Attribute_Priority
=>
5008 Conctyp
: Entity_Id
;
5009 Object_Parm
: Node_Id
;
5011 RT_Subprg_Name
: Node_Id
;
5014 -- Look for the enclosing concurrent type
5016 Conctyp
:= Current_Scope
;
5017 while not Is_Concurrent_Type
(Conctyp
) loop
5018 Conctyp
:= Scope
(Conctyp
);
5021 pragma Assert
(Is_Protected_Type
(Conctyp
));
5023 -- Generate the actual of the call
5025 Subprg
:= Current_Scope
;
5026 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
5027 Subprg
:= Scope
(Subprg
);
5030 -- Use of 'Priority inside protected entries and barriers (in
5031 -- both cases the type of the first formal of their expanded
5032 -- subprogram is Address)
5034 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
)))
5038 New_Itype
: Entity_Id
;
5041 -- In the expansion of protected entries the type of the
5042 -- first formal of the Protected_Body_Subprogram is an
5043 -- Address. In order to reference the _object component
5046 -- type T is access p__ptTV;
5049 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5050 Set_Etype
(New_Itype
, New_Itype
);
5051 Set_Directly_Designated_Type
(New_Itype
,
5052 Corresponding_Record_Type
(Conctyp
));
5053 Freeze_Itype
(New_Itype
, N
);
5056 -- T!(O)._object'unchecked_access
5059 Make_Attribute_Reference
(Loc
,
5061 Make_Selected_Component
(Loc
,
5063 Unchecked_Convert_To
(New_Itype
,
5066 (Protected_Body_Subprogram
(Subprg
)),
5069 Make_Identifier
(Loc
, Name_uObject
)),
5070 Attribute_Name
=> Name_Unchecked_Access
);
5073 -- Use of 'Priority inside a protected subprogram
5077 Make_Attribute_Reference
(Loc
,
5079 Make_Selected_Component
(Loc
,
5080 Prefix
=> New_Occurrence_Of
5082 (Protected_Body_Subprogram
(Subprg
)),
5084 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5085 Attribute_Name
=> Name_Unchecked_Access
);
5088 -- Select the appropriate run-time subprogram
5090 if Number_Entries
(Conctyp
) = 0 then
5092 New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
5095 New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
5099 Make_Function_Call
(Loc
,
5100 Name
=> RT_Subprg_Name
,
5101 Parameter_Associations
=> New_List
(Object_Parm
));
5105 -- Avoid the generation of extra checks on the pointer to the
5106 -- protected object.
5108 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5115 when Attribute_Range_Length
=> Range_Length
: begin
5117 -- The only special processing required is for the case where
5118 -- Range_Length is applied to an enumeration type with holes.
5119 -- In this case we transform
5125 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5127 -- So that the result reflects the proper Pos values instead
5128 -- of the underlying representations.
5130 if Is_Enumeration_Type
(Ptyp
)
5131 and then Has_Non_Standard_Rep
(Ptyp
)
5136 Make_Op_Subtract
(Loc
,
5138 Make_Attribute_Reference
(Loc
,
5139 Attribute_Name
=> Name_Pos
,
5140 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5141 Expressions
=> New_List
(
5142 Make_Attribute_Reference
(Loc
,
5143 Attribute_Name
=> Name_Last
,
5144 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
)))),
5147 Make_Attribute_Reference
(Loc
,
5148 Attribute_Name
=> Name_Pos
,
5149 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5150 Expressions
=> New_List
(
5151 Make_Attribute_Reference
(Loc
,
5152 Attribute_Name
=> Name_First
,
5153 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
))))),
5155 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
5157 Analyze_And_Resolve
(N
, Typ
);
5159 -- For all other cases, the attribute is handled by the back end, but
5160 -- we need to deal with the case of the range check on a universal
5164 Apply_Universal_Integer_Attribute_Checks
(N
);
5172 when Attribute_Read
=> Read
: declare
5173 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5174 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
5175 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5185 -- If no underlying type, we have an error that will be diagnosed
5186 -- elsewhere, so here we just completely ignore the expansion.
5192 -- Stream operations can appear in user code even if the restriction
5193 -- No_Streams is active (for example, when instantiating a predefined
5194 -- container). In that case rewrite the attribute as a Raise to
5195 -- prevent any run-time use.
5197 if Restriction_Active
(No_Streams
) then
5199 Make_Raise_Program_Error
(Sloc
(N
),
5200 Reason
=> PE_Stream_Operation_Not_Allowed
));
5201 Set_Etype
(N
, B_Type
);
5205 -- The simple case, if there is a TSS for Read, just call it
5207 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
5209 if Present
(Pname
) then
5213 -- If there is a Stream_Convert pragma, use it, we rewrite
5215 -- sourcetyp'Read (stream, Item)
5219 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5221 -- where strmread is the given Read function that converts an
5222 -- argument of type strmtyp to type sourcetyp or a type from which
5223 -- it is derived. The conversion to sourcetyp is required in the
5226 -- A special case arises if Item is a type conversion in which
5227 -- case, we have to expand to:
5229 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5231 -- where Itemx is the expression of the type conversion (i.e.
5232 -- the actual object), and typex is the type of Itemx.
5234 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5236 if Present
(Prag
) then
5237 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
5238 Rfunc
:= Entity
(Expression
(Arg2
));
5239 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5241 OK_Convert_To
(B_Type
,
5242 Make_Function_Call
(Loc
,
5243 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
5244 Parameter_Associations
=> New_List
(
5245 Make_Attribute_Reference
(Loc
,
5248 (Etype
(First_Formal
(Rfunc
)), Loc
),
5249 Attribute_Name
=> Name_Input
,
5250 Expressions
=> New_List
(
5251 Relocate_Node
(First
(Exprs
)))))));
5253 if Nkind
(Lhs
) = N_Type_Conversion
then
5254 Lhs
:= Expression
(Lhs
);
5255 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5259 Make_Assignment_Statement
(Loc
,
5261 Expression
=> Rhs
));
5262 Set_Assignment_OK
(Lhs
);
5266 -- For elementary types, we call the I_xxx routine using the first
5267 -- parameter and then assign the result into the second parameter.
5268 -- We set Assignment_OK to deal with the conversion case.
5270 elsif Is_Elementary_Type
(U_Type
) then
5276 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
5277 Rhs
:= Build_Elementary_Input_Call
(N
);
5279 if Nkind
(Lhs
) = N_Type_Conversion
then
5280 Lhs
:= Expression
(Lhs
);
5281 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
5284 Set_Assignment_OK
(Lhs
);
5287 Make_Assignment_Statement
(Loc
,
5289 Expression
=> Rhs
));
5297 elsif Is_Array_Type
(U_Type
) then
5298 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
5299 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5301 -- Tagged type case, use the primitive Read function. Note that
5302 -- this will dispatch in the class-wide case which is what we want
5304 elsif Is_Tagged_Type
(U_Type
) then
5305 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
5307 -- All other record type cases, including protected records. The
5308 -- latter only arise for expander generated code for handling
5309 -- shared passive partition access.
5313 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5315 -- Ada 2005 (AI-216): Program_Error is raised when executing
5316 -- the default implementation of the Read attribute of an
5317 -- Unchecked_Union type.
5319 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
5321 Make_Raise_Program_Error
(Loc
,
5322 Reason
=> PE_Unchecked_Union_Restriction
));
5325 if Has_Discriminants
(U_Type
)
5327 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5329 Build_Mutable_Record_Read_Procedure
5330 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5332 Build_Record_Read_Procedure
5333 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5336 -- Suppress checks, uninitialized or otherwise invalid
5337 -- data does not cause constraint errors to be raised for
5338 -- a complete record read.
5340 Insert_Action
(N
, Decl
, All_Checks
);
5344 Rewrite_Stream_Proc_Call
(Pname
);
5351 -- Ref is identical to To_Address, see To_Address for processing
5357 -- Transforms 'Remainder into a call to the floating-point attribute
5358 -- function Remainder in Fat_xxx (where xxx is the root type)
5360 when Attribute_Remainder
=>
5361 Expand_Fpt_Attribute_RR
(N
);
5367 -- Transform 'Result into reference to _Result formal. At the point
5368 -- where a legal 'Result attribute is expanded, we know that we are in
5369 -- the context of a _Postcondition function with a _Result parameter.
5371 when Attribute_Result
=>
5372 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
5373 Analyze_And_Resolve
(N
, Typ
);
5379 -- The handling of the Round attribute is quite delicate. The processing
5380 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5381 -- semantics of Round, but we do not want anything to do with universal
5382 -- real at runtime, since this corresponds to using floating-point
5385 -- What we have now is that the Etype of the Round attribute correctly
5386 -- indicates the final result type. The operand of the Round is the
5387 -- conversion to universal real, described above, and the operand of
5388 -- this conversion is the actual operand of Round, which may be the
5389 -- special case of a fixed point multiplication or division (Etype =
5392 -- The exapander will expand first the operand of the conversion, then
5393 -- the conversion, and finally the round attribute itself, since we
5394 -- always work inside out. But we cannot simply process naively in this
5395 -- order. In the semantic world where universal fixed and real really
5396 -- exist and have infinite precision, there is no problem, but in the
5397 -- implementation world, where universal real is a floating-point type,
5398 -- we would get the wrong result.
5400 -- So the approach is as follows. First, when expanding a multiply or
5401 -- divide whose type is universal fixed, we do nothing at all, instead
5402 -- deferring the operation till later.
5404 -- The actual processing is done in Expand_N_Type_Conversion which
5405 -- handles the special case of Round by looking at its parent to see if
5406 -- it is a Round attribute, and if it is, handling the conversion (or
5407 -- its fixed multiply/divide child) in an appropriate manner.
5409 -- This means that by the time we get to expanding the Round attribute
5410 -- itself, the Round is nothing more than a type conversion (and will
5411 -- often be a null type conversion), so we just replace it with the
5412 -- appropriate conversion operation.
5414 when Attribute_Round
=>
5416 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
5417 Analyze_And_Resolve
(N
);
5423 -- Transforms 'Rounding into a call to the floating-point attribute
5424 -- function Rounding in Fat_xxx (where xxx is the root type)
5425 -- Expansion is avoided for cases the back end can handle directly.
5427 when Attribute_Rounding
=>
5428 if not Is_Inline_Floating_Point_Attribute
(N
) then
5429 Expand_Fpt_Attribute_R
(N
);
5436 -- Transforms 'Scaling into a call to the floating-point attribute
5437 -- function Scaling in Fat_xxx (where xxx is the root type)
5439 when Attribute_Scaling
=>
5440 Expand_Fpt_Attribute_RI
(N
);
5442 -------------------------
5443 -- Simple_Storage_Pool --
5444 -------------------------
5446 when Attribute_Simple_Storage_Pool
=>
5448 Make_Type_Conversion
(Loc
,
5449 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5450 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5451 Analyze_And_Resolve
(N
, Typ
);
5457 when Attribute_Size |
5458 Attribute_Object_Size |
5459 Attribute_Value_Size |
5460 Attribute_VADS_Size
=> Size
:
5467 -- Processing for VADS_Size case. Note that this processing removes
5468 -- all traces of VADS_Size from the tree, and completes all required
5469 -- processing for VADS_Size by translating the attribute reference
5470 -- to an appropriate Size or Object_Size reference.
5472 if Id
= Attribute_VADS_Size
5473 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5475 -- If the size is specified, then we simply use the specified
5476 -- size. This applies to both types and objects. The size of an
5477 -- object can be specified in the following ways:
5479 -- An explicit size object is given for an object
5480 -- A component size is specified for an indexed component
5481 -- A component clause is specified for a selected component
5482 -- The object is a component of a packed composite object
5484 -- If the size is specified, then VADS_Size of an object
5486 if (Is_Entity_Name
(Pref
)
5487 and then Present
(Size_Clause
(Entity
(Pref
))))
5489 (Nkind
(Pref
) = N_Component_Clause
5490 and then (Present
(Component_Clause
5491 (Entity
(Selector_Name
(Pref
))))
5492 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5494 (Nkind
(Pref
) = N_Indexed_Component
5495 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5496 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5498 Set_Attribute_Name
(N
, Name_Size
);
5500 -- Otherwise if we have an object rather than a type, then the
5501 -- VADS_Size attribute applies to the type of the object, rather
5502 -- than the object itself. This is one of the respects in which
5503 -- VADS_Size differs from Size.
5506 if (not Is_Entity_Name
(Pref
)
5507 or else not Is_Type
(Entity
(Pref
)))
5508 and then (Is_Scalar_Type
(Ptyp
) or else Is_Constrained
(Ptyp
))
5510 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
5513 -- For a scalar type for which no size was explicitly given,
5514 -- VADS_Size means Object_Size. This is the other respect in
5515 -- which VADS_Size differs from Size.
5517 if Is_Scalar_Type
(Ptyp
) and then No
(Size_Clause
(Ptyp
)) then
5518 Set_Attribute_Name
(N
, Name_Object_Size
);
5520 -- In all other cases, Size and VADS_Size are the sane
5523 Set_Attribute_Name
(N
, Name_Size
);
5528 -- If the prefix is X'Class, we transform it into a direct reference
5529 -- to the class-wide type, because the back end must not see a 'Class
5532 if Is_Entity_Name
(Pref
)
5533 and then Is_Class_Wide_Type
(Entity
(Pref
))
5535 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
5538 -- For X'Size applied to an object of a class-wide type, transform
5539 -- X'Size into a call to the primitive operation _Size applied to X.
5541 elsif Is_Class_Wide_Type
(Ptyp
) then
5543 -- No need to do anything else compiling under restriction
5544 -- No_Dispatching_Calls. During the semantic analysis we
5545 -- already noted this restriction violation.
5547 if Restriction_Active
(No_Dispatching_Calls
) then
5552 Make_Function_Call
(Loc
,
5553 Name
=> New_Occurrence_Of
5554 (Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
5555 Parameter_Associations
=> New_List
(Pref
));
5557 if Typ
/= Standard_Long_Long_Integer
then
5559 -- The context is a specific integer type with which the
5560 -- original attribute was compatible. The function has a
5561 -- specific type as well, so to preserve the compatibility
5562 -- we must convert explicitly.
5564 New_Node
:= Convert_To
(Typ
, New_Node
);
5567 Rewrite
(N
, New_Node
);
5568 Analyze_And_Resolve
(N
, Typ
);
5571 -- Case of known RM_Size of a type
5573 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
5574 and then Is_Entity_Name
(Pref
)
5575 and then Is_Type
(Entity
(Pref
))
5576 and then Known_Static_RM_Size
(Entity
(Pref
))
5578 Siz
:= RM_Size
(Entity
(Pref
));
5580 -- Case of known Esize of a type
5582 elsif Id
= Attribute_Object_Size
5583 and then Is_Entity_Name
(Pref
)
5584 and then Is_Type
(Entity
(Pref
))
5585 and then Known_Static_Esize
(Entity
(Pref
))
5587 Siz
:= Esize
(Entity
(Pref
));
5589 -- Case of known size of object
5591 elsif Id
= Attribute_Size
5592 and then Is_Entity_Name
(Pref
)
5593 and then Is_Object
(Entity
(Pref
))
5594 and then Known_Esize
(Entity
(Pref
))
5595 and then Known_Static_Esize
(Entity
(Pref
))
5597 Siz
:= Esize
(Entity
(Pref
));
5599 -- For an array component, we can do Size in the front end
5600 -- if the component_size of the array is set.
5602 elsif Nkind
(Pref
) = N_Indexed_Component
then
5603 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
5605 -- For a record component, we can do Size in the front end if there
5606 -- is a component clause, or if the record is packed and the
5607 -- component's size is known at compile time.
5609 elsif Nkind
(Pref
) = N_Selected_Component
then
5611 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
5612 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5615 if Present
(Component_Clause
(Comp
)) then
5616 Siz
:= Esize
(Comp
);
5618 elsif Is_Packed
(Rec
) then
5619 Siz
:= RM_Size
(Ptyp
);
5622 Apply_Universal_Integer_Attribute_Checks
(N
);
5627 -- All other cases are handled by the back end
5630 Apply_Universal_Integer_Attribute_Checks
(N
);
5632 -- If Size is applied to a formal parameter that is of a packed
5633 -- array subtype, then apply Size to the actual subtype.
5635 if Is_Entity_Name
(Pref
)
5636 and then Is_Formal
(Entity
(Pref
))
5637 and then Is_Array_Type
(Ptyp
)
5638 and then Is_Packed
(Ptyp
)
5641 Make_Attribute_Reference
(Loc
,
5643 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
5644 Attribute_Name
=> Name_Size
));
5645 Analyze_And_Resolve
(N
, Typ
);
5648 -- If Size applies to a dereference of an access to unconstrained
5649 -- packed array, the back end needs to see its unconstrained
5650 -- nominal type, but also a hint to the actual constrained type.
5652 if Nkind
(Pref
) = N_Explicit_Dereference
5653 and then Is_Array_Type
(Ptyp
)
5654 and then not Is_Constrained
(Ptyp
)
5655 and then Is_Packed
(Ptyp
)
5657 Set_Actual_Designated_Subtype
(Pref
,
5658 Get_Actual_Subtype
(Pref
));
5664 -- Common processing for record and array component case
5666 if Siz
/= No_Uint
and then Siz
/= 0 then
5668 CS
: constant Boolean := Comes_From_Source
(N
);
5671 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
5673 -- This integer literal is not a static expression. We do not
5674 -- call Analyze_And_Resolve here, because this would activate
5675 -- the circuit for deciding that a static value was out of
5676 -- range, and we don't want that.
5678 -- So just manually set the type, mark the expression as non-
5679 -- static, and then ensure that the result is checked properly
5680 -- if the attribute comes from source (if it was internally
5681 -- generated, we never need a constraint check).
5684 Set_Is_Static_Expression
(N
, False);
5687 Apply_Constraint_Check
(N
, Typ
);
5697 when Attribute_Storage_Pool
=>
5699 Make_Type_Conversion
(Loc
,
5700 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5701 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5702 Analyze_And_Resolve
(N
, Typ
);
5708 when Attribute_Storage_Size
=> Storage_Size
: declare
5709 Alloc_Op
: Entity_Id
:= Empty
;
5713 -- Access type case, always go to the root type
5715 -- The case of access types results in a value of zero for the case
5716 -- where no storage size attribute clause has been given. If a
5717 -- storage size has been given, then the attribute is converted
5718 -- to a reference to the variable used to hold this value.
5720 if Is_Access_Type
(Ptyp
) then
5721 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
5723 Make_Attribute_Reference
(Loc
,
5724 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5725 Attribute_Name
=> Name_Max
,
5726 Expressions
=> New_List
(
5727 Make_Integer_Literal
(Loc
, 0),
5730 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
5732 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
5734 -- If the access type is associated with a simple storage pool
5735 -- object, then attempt to locate the optional Storage_Size
5736 -- function of the simple storage pool type. If not found,
5737 -- then the result will default to zero.
5739 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
5740 Name_Simple_Storage_Pool_Type
))
5743 Pool_Type
: constant Entity_Id
:=
5744 Base_Type
(Etype
(Entity
(N
)));
5747 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
5748 while Present
(Alloc_Op
) loop
5749 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
5750 and then Present
(First_Formal
(Alloc_Op
))
5751 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
5756 Alloc_Op
:= Homonym
(Alloc_Op
);
5760 -- In the normal Storage_Pool case, retrieve the primitive
5761 -- function associated with the pool type.
5766 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
5767 Attribute_Name
(N
));
5770 -- If Storage_Size wasn't found (can only occur in the simple
5771 -- storage pool case), then simply use zero for the result.
5773 if not Present
(Alloc_Op
) then
5774 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5776 -- Otherwise, rewrite the allocator as a call to pool type's
5777 -- Storage_Size function.
5782 Make_Function_Call
(Loc
,
5784 New_Occurrence_Of
(Alloc_Op
, Loc
),
5786 Parameter_Associations
=> New_List
(
5788 (Associated_Storage_Pool
5789 (Root_Type
(Ptyp
)), Loc
)))));
5793 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5796 Analyze_And_Resolve
(N
, Typ
);
5798 -- For tasks, we retrieve the size directly from the TCB. The
5799 -- size may depend on a discriminant of the type, and therefore
5800 -- can be a per-object expression, so type-level information is
5801 -- not sufficient in general. There are four cases to consider:
5803 -- a) If the attribute appears within a task body, the designated
5804 -- TCB is obtained by a call to Self.
5806 -- b) If the prefix of the attribute is the name of a task object,
5807 -- the designated TCB is the one stored in the corresponding record.
5809 -- c) If the prefix is a task type, the size is obtained from the
5810 -- size variable created for each task type
5812 -- d) If no storage_size was specified for the type , there is no
5813 -- size variable, and the value is a system-specific default.
5816 if In_Open_Scopes
(Ptyp
) then
5818 -- Storage_Size (Self)
5822 Make_Function_Call
(Loc
,
5824 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5825 Parameter_Associations
=>
5827 Make_Function_Call
(Loc
,
5829 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
5831 elsif not Is_Entity_Name
(Pref
)
5832 or else not Is_Type
(Entity
(Pref
))
5834 -- Storage_Size (Rec (Obj).Size)
5838 Make_Function_Call
(Loc
,
5840 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5841 Parameter_Associations
=>
5843 Make_Selected_Component
(Loc
,
5845 Unchecked_Convert_To
(
5846 Corresponding_Record_Type
(Ptyp
),
5847 New_Copy_Tree
(Pref
)),
5849 Make_Identifier
(Loc
, Name_uTask_Id
))))));
5851 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
5853 -- Static storage size pragma given for type: retrieve value
5854 -- from its allocated storage variable.
5858 Make_Function_Call
(Loc
,
5859 Name
=> New_Occurrence_Of
(
5860 RTE
(RE_Adjust_Storage_Size
), Loc
),
5861 Parameter_Associations
=>
5864 Storage_Size_Variable
(Ptyp
), Loc
)))));
5866 -- Get system default
5870 Make_Function_Call
(Loc
,
5873 RTE
(RE_Default_Stack_Size
), Loc
))));
5876 Analyze_And_Resolve
(N
, Typ
);
5884 when Attribute_Stream_Size
=>
5886 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
5887 Analyze_And_Resolve
(N
, Typ
);
5893 -- 1. Deal with enumeration types with holes.
5894 -- 2. For floating-point, generate call to attribute function.
5895 -- 3. For other cases, deal with constraint checking.
5897 when Attribute_Succ
=> Succ
: declare
5898 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5902 -- For enumeration types with non-standard representations, we
5903 -- expand typ'Succ (x) into
5905 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5907 -- If the representation is contiguous, we compute instead
5908 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5910 if Is_Enumeration_Type
(Ptyp
)
5911 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5913 if Has_Contiguous_Rep
(Etyp
) then
5915 Unchecked_Convert_To
(Ptyp
,
5918 Make_Integer_Literal
(Loc
,
5919 Enumeration_Rep
(First_Literal
(Ptyp
))),
5921 Make_Function_Call
(Loc
,
5924 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5926 Parameter_Associations
=>
5928 Unchecked_Convert_To
(Ptyp
,
5931 Unchecked_Convert_To
(Standard_Integer
,
5932 Relocate_Node
(First
(Exprs
))),
5934 Make_Integer_Literal
(Loc
, 1))),
5935 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5937 -- Add Boolean parameter True, to request program errror if
5938 -- we have a bad representation on our hands. Add False if
5939 -- checks are suppressed.
5941 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5943 Make_Indexed_Component
(Loc
,
5946 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5947 Expressions
=> New_List
(
5950 Make_Function_Call
(Loc
,
5953 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5954 Parameter_Associations
=> Exprs
),
5955 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5958 Analyze_And_Resolve
(N
, Typ
);
5960 -- For floating-point, we transform 'Succ into a call to the Succ
5961 -- floating-point attribute function in Fat_xxx (xxx is root type)
5963 elsif Is_Floating_Point_Type
(Ptyp
) then
5964 Expand_Fpt_Attribute_R
(N
);
5965 Analyze_And_Resolve
(N
, Typ
);
5967 -- For modular types, nothing to do (no overflow, since wraps)
5969 elsif Is_Modular_Integer_Type
(Ptyp
) then
5972 -- For other types, if argument is marked as needing a range check or
5973 -- overflow checking is enabled, we must generate a check.
5975 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5976 or else Do_Range_Check
(First
(Exprs
))
5978 Set_Do_Range_Check
(First
(Exprs
), False);
5979 Expand_Pred_Succ_Attribute
(N
);
5987 -- Transforms X'Tag into a direct reference to the tag of X
5989 when Attribute_Tag
=> Tag
: declare
5991 Prefix_Is_Type
: Boolean;
5994 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
5995 Ttyp
:= Entity
(Pref
);
5996 Prefix_Is_Type
:= True;
5999 Prefix_Is_Type
:= False;
6002 if Is_Class_Wide_Type
(Ttyp
) then
6003 Ttyp
:= Root_Type
(Ttyp
);
6006 Ttyp
:= Underlying_Type
(Ttyp
);
6008 -- Ada 2005: The type may be a synchronized tagged type, in which
6009 -- case the tag information is stored in the corresponding record.
6011 if Is_Concurrent_Type
(Ttyp
) then
6012 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6015 if Prefix_Is_Type
then
6017 -- For VMs we leave the type attribute unexpanded because
6018 -- there's not a dispatching table to reference.
6020 if Tagged_Type_Expansion
then
6022 Unchecked_Convert_To
(RTE
(RE_Tag
),
6024 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6025 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6028 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6029 -- references the primary tag of the actual object. If 'Tag is
6030 -- applied to class-wide interface objects we generate code that
6031 -- displaces "this" to reference the base of the object.
6033 elsif Comes_From_Source
(N
)
6034 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6035 and then Is_Interface
(Etype
(Prefix
(N
)))
6038 -- (To_Tag_Ptr (Prefix'Address)).all
6040 -- Note that Prefix'Address is recursively expanded into a call
6041 -- to Base_Address (Obj.Tag)
6043 -- Not needed for VM targets, since all handled by the VM
6045 if Tagged_Type_Expansion
then
6047 Make_Explicit_Dereference
(Loc
,
6048 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
6049 Make_Attribute_Reference
(Loc
,
6050 Prefix
=> Relocate_Node
(Pref
),
6051 Attribute_Name
=> Name_Address
))));
6052 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6057 Make_Selected_Component
(Loc
,
6058 Prefix
=> Relocate_Node
(Pref
),
6060 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
6061 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6069 -- Transforms 'Terminated attribute into a call to Terminated function
6071 when Attribute_Terminated
=> Terminated
:
6073 -- The prefix of Terminated is of a task interface class-wide type.
6075 -- terminated (Task_Id (Pref._disp_get_task_id));
6077 if Ada_Version
>= Ada_2005
6078 and then Ekind
(Ptyp
) = E_Class_Wide_Type
6079 and then Is_Interface
(Ptyp
)
6080 and then Is_Task_Interface
(Ptyp
)
6083 Make_Function_Call
(Loc
,
6085 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
6086 Parameter_Associations
=> New_List
(
6087 Make_Unchecked_Type_Conversion
(Loc
,
6089 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
6091 Make_Selected_Component
(Loc
,
6093 New_Copy_Tree
(Pref
),
6095 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
6097 elsif Restricted_Profile
then
6099 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
6103 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
6106 Analyze_And_Resolve
(N
, Standard_Boolean
);
6113 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6114 -- unchecked conversion from (integral) type of X to type address.
6116 when Attribute_To_Address | Attribute_Ref
=>
6118 Unchecked_Convert_To
(RTE
(RE_Address
),
6119 Relocate_Node
(First
(Exprs
))));
6120 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
6126 when Attribute_To_Any
=> To_Any
: declare
6127 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6128 Decls
: constant List_Id
:= New_List
;
6134 Relocate_Node
(First
(Exprs
))), Decls
));
6135 Insert_Actions
(N
, Decls
);
6136 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
6143 -- Transforms 'Truncation into a call to the floating-point attribute
6144 -- function Truncation in Fat_xxx (where xxx is the root type).
6145 -- Expansion is avoided for cases the back end can handle directly.
6147 when Attribute_Truncation
=>
6148 if not Is_Inline_Floating_Point_Attribute
(N
) then
6149 Expand_Fpt_Attribute_R
(N
);
6156 when Attribute_TypeCode
=> TypeCode
: declare
6157 P_Type
: constant Entity_Id
:= Etype
(Pref
);
6158 Decls
: constant List_Id
:= New_List
;
6160 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
6161 Insert_Actions
(N
, Decls
);
6162 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
6165 -----------------------
6166 -- Unbiased_Rounding --
6167 -----------------------
6169 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6170 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6171 -- root type). Expansion is avoided for cases the back end can handle
6174 when Attribute_Unbiased_Rounding
=>
6175 if not Is_Inline_Floating_Point_Attribute
(N
) then
6176 Expand_Fpt_Attribute_R
(N
);
6183 when Attribute_UET_Address
=> UET_Address
: declare
6184 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
6188 Make_Object_Declaration
(Loc
,
6189 Defining_Identifier
=> Ent
,
6190 Aliased_Present
=> True,
6191 Object_Definition
=>
6192 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
6194 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
6195 -- in normal external form.
6197 Get_External_Unit_Name_String
(Get_Unit_Name
(Pref
));
6198 Name_Buffer
(1 + 7 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
6199 Name_Len
:= Name_Len
+ 7;
6200 Name_Buffer
(1 .. 7) := "__gnat_";
6201 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 5) := "__SDP";
6202 Name_Len
:= Name_Len
+ 5;
6204 Set_Is_Imported
(Ent
);
6205 Set_Interface_Name
(Ent
,
6206 Make_String_Literal
(Loc
,
6207 Strval
=> String_From_Name_Buffer
));
6209 -- Set entity as internal to ensure proper Sprint output of its
6210 -- implicit importation.
6212 Set_Is_Internal
(Ent
);
6215 Make_Attribute_Reference
(Loc
,
6216 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
6217 Attribute_Name
=> Name_Address
));
6219 Analyze_And_Resolve
(N
, Typ
);
6226 when Attribute_Update
=>
6227 Expand_Update_Attribute
(N
);
6233 -- The processing for VADS_Size is shared with Size
6239 -- For enumeration types with a standard representation, and for all
6240 -- other types, Val is handled by the back end. For enumeration types
6241 -- with a non-standard representation we use the _Pos_To_Rep array that
6242 -- was created when the type was frozen.
6244 when Attribute_Val
=> Val
: declare
6245 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
6248 if Is_Enumeration_Type
(Etyp
)
6249 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6251 if Has_Contiguous_Rep
(Etyp
) then
6253 Rep_Node
: constant Node_Id
:=
6254 Unchecked_Convert_To
(Etyp
,
6257 Make_Integer_Literal
(Loc
,
6258 Enumeration_Rep
(First_Literal
(Etyp
))),
6260 (Convert_To
(Standard_Integer
,
6261 Relocate_Node
(First
(Exprs
))))));
6265 Unchecked_Convert_To
(Etyp
,
6268 Make_Integer_Literal
(Loc
,
6269 Enumeration_Rep
(First_Literal
(Etyp
))),
6271 Make_Function_Call
(Loc
,
6274 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6275 Parameter_Associations
=> New_List
(
6277 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
6282 Make_Indexed_Component
(Loc
,
6283 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
6284 Expressions
=> New_List
(
6285 Convert_To
(Standard_Integer
,
6286 Relocate_Node
(First
(Exprs
))))));
6289 Analyze_And_Resolve
(N
, Typ
);
6291 -- If the argument is marked as requiring a range check then generate
6294 elsif Do_Range_Check
(First
(Exprs
)) then
6295 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
6303 -- The code for valid is dependent on the particular types involved.
6304 -- See separate sections below for the generated code in each case.
6306 when Attribute_Valid
=> Valid
: declare
6307 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
6310 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
6311 -- Save the validity checking mode. We always turn off validity
6312 -- checking during process of 'Valid since this is one place
6313 -- where we do not want the implicit validity checks to intefere
6314 -- with the explicit validity check that the programmer is doing.
6316 function Make_Range_Test
return Node_Id
;
6317 -- Build the code for a range test of the form
6318 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6320 ---------------------
6321 -- Make_Range_Test --
6322 ---------------------
6324 function Make_Range_Test
return Node_Id
is
6325 Temp
: constant Node_Id
:= Duplicate_Subexpr
(Pref
);
6328 -- The value whose validity is being checked has been captured in
6329 -- an object declaration. We certainly don't want this object to
6330 -- appear valid because the declaration initializes it.
6332 if Is_Entity_Name
(Temp
) then
6333 Set_Is_Known_Valid
(Entity
(Temp
), False);
6339 Unchecked_Convert_To
(Btyp
, Temp
),
6343 Unchecked_Convert_To
(Btyp
,
6344 Make_Attribute_Reference
(Loc
,
6345 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6346 Attribute_Name
=> Name_First
)),
6348 Unchecked_Convert_To
(Btyp
,
6349 Make_Attribute_Reference
(Loc
,
6350 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6351 Attribute_Name
=> Name_Last
))));
6352 end Make_Range_Test
;
6354 -- Start of processing for Attribute_Valid
6357 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6358 -- will be handled by the back-end directly.
6360 if CodePeer_Mode
and then Comes_From_Source
(N
) then
6364 -- Turn off validity checks. We do not want any implicit validity
6365 -- checks to intefere with the explicit check from the attribute
6367 Validity_Checks_On
:= False;
6369 -- Retrieve the base type. Handle the case where the base type is a
6370 -- private enumeration type.
6372 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
6373 Btyp
:= Full_View
(Btyp
);
6376 -- Floating-point case. This case is handled by the Valid attribute
6377 -- code in the floating-point attribute run-time library.
6379 if Is_Floating_Point_Type
(Ptyp
) then
6380 Float_Valid
: declare
6384 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
6385 -- Return entity for Pkg.Nam
6387 --------------------
6388 -- Get_Fat_Entity --
6389 --------------------
6391 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
6392 Exp_Name
: constant Node_Id
:=
6393 Make_Selected_Component
(Loc
,
6394 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
6395 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
6397 Find_Selected_Component
(Exp_Name
);
6398 return Entity
(Exp_Name
);
6401 -- Start of processing for Float_Valid
6404 case Float_Rep
(Btyp
) is
6406 -- The AAMP back end handles Valid for floating-point types
6409 Analyze_And_Resolve
(Pref
, Ptyp
);
6410 Set_Etype
(N
, Standard_Boolean
);
6414 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6416 -- If the prefix is a reverse SSO component, or is
6417 -- possibly unaligned, first create a temporary copy
6418 -- that is in native SSO, and properly aligned. Make it
6419 -- Volatile to prevent folding in the back-end. Note
6420 -- that we use an intermediate constrained string type
6421 -- to initialize the temporary, as the value at hand
6422 -- might be invalid, and in that case it cannot be copied
6423 -- using a floating point register.
6425 if In_Reverse_Storage_Order_Object
(Pref
)
6427 Is_Possibly_Unaligned_Object
(Pref
)
6430 Temp
: constant Entity_Id
:=
6431 Make_Temporary
(Loc
, 'F');
6433 Fat_S
: constant Entity_Id
:=
6434 Get_Fat_Entity
(Name_S
);
6435 -- Constrained string subtype of appropriate size
6437 Fat_P
: constant Entity_Id
:=
6438 Get_Fat_Entity
(Name_P
);
6441 Decl
: constant Node_Id
:=
6442 Make_Object_Declaration
(Loc
,
6443 Defining_Identifier
=> Temp
,
6444 Aliased_Present
=> True,
6445 Object_Definition
=>
6446 New_Occurrence_Of
(Ptyp
, Loc
));
6449 Set_Aspect_Specifications
(Decl
, New_List
(
6450 Make_Aspect_Specification
(Loc
,
6452 Make_Identifier
(Loc
, Name_Volatile
))));
6458 Make_Assignment_Statement
(Loc
,
6460 Make_Explicit_Dereference
(Loc
,
6462 Unchecked_Convert_To
(Fat_P
,
6463 Make_Attribute_Reference
(Loc
,
6465 New_Occurrence_Of
(Temp
, Loc
),
6467 Name_Unrestricted_Access
))),
6469 Unchecked_Convert_To
(Fat_S
,
6470 Relocate_Node
(Pref
)))),
6472 Suppress
=> All_Checks
);
6474 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
6478 -- We now have an object of the proper endianness and
6479 -- alignment, and can construct a Valid attribute.
6481 -- We make sure the prefix of this valid attribute is
6482 -- marked as not coming from source, to avoid losing
6483 -- warnings from 'Valid looking like a possible update.
6485 Set_Comes_From_Source
(Pref
, False);
6487 Expand_Fpt_Attribute
6488 (N
, Pkg
, Name_Valid
,
6490 Make_Attribute_Reference
(Loc
,
6491 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6492 Attribute_Name
=> Name_Unrestricted_Access
)));
6495 -- One more task, we still need a range check. Required
6496 -- only if we have a constraint, since the Valid routine
6497 -- catches infinities properly (infinities are never valid).
6499 -- The way we do the range check is simply to create the
6500 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6502 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
6505 Left_Opnd
=> Relocate_Node
(N
),
6508 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
6509 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6513 -- Enumeration type with holes
6515 -- For enumeration types with holes, the Pos value constructed by
6516 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6517 -- second argument of False returns minus one for an invalid value,
6518 -- and the non-negative pos value for a valid value, so the
6519 -- expansion of X'Valid is simply:
6521 -- type(X)'Pos (X) >= 0
6523 -- We can't quite generate it that way because of the requirement
6524 -- for the non-standard second argument of False in the resulting
6525 -- rep_to_pos call, so we have to explicitly create:
6527 -- _rep_to_pos (X, False) >= 0
6529 -- If we have an enumeration subtype, we also check that the
6530 -- value is in range:
6532 -- _rep_to_pos (X, False) >= 0
6534 -- (X >= type(X)'First and then type(X)'Last <= X)
6536 elsif Is_Enumeration_Type
(Ptyp
)
6537 and then Present
(Enum_Pos_To_Rep
(Btyp
))
6542 Make_Function_Call
(Loc
,
6544 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
6545 Parameter_Associations
=> New_List
(
6547 New_Occurrence_Of
(Standard_False
, Loc
))),
6548 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
6552 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
6554 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
6556 -- The call to Make_Range_Test will create declarations
6557 -- that need a proper insertion point, but Pref is now
6558 -- attached to a node with no ancestor. Attach to tree
6559 -- even if it is to be rewritten below.
6561 Set_Parent
(Tst
, Parent
(N
));
6565 Left_Opnd
=> Make_Range_Test
,
6571 -- Fortran convention booleans
6573 -- For the very special case of Fortran convention booleans, the
6574 -- value is always valid, since it is an integer with the semantics
6575 -- that non-zero is true, and any value is permissible.
6577 elsif Is_Boolean_Type
(Ptyp
)
6578 and then Convention
(Ptyp
) = Convention_Fortran
6580 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6582 -- For biased representations, we will be doing an unchecked
6583 -- conversion without unbiasing the result. That means that the range
6584 -- test has to take this into account, and the proper form of the
6587 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6589 elsif Has_Biased_Representation
(Ptyp
) then
6590 Btyp
:= RTE
(RE_Unsigned_32
);
6594 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
6596 Unchecked_Convert_To
(Btyp
,
6597 Make_Attribute_Reference
(Loc
,
6598 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6599 Attribute_Name
=> Name_Range_Length
))));
6601 -- For all other scalar types, what we want logically is a
6604 -- X in type(X)'First .. type(X)'Last
6606 -- But that's precisely what won't work because of possible
6607 -- unwanted optimization (and indeed the basic motivation for
6608 -- the Valid attribute is exactly that this test does not work).
6609 -- What will work is:
6611 -- Btyp!(X) >= Btyp!(type(X)'First)
6613 -- Btyp!(X) <= Btyp!(type(X)'Last)
6615 -- where Btyp is an integer type large enough to cover the full
6616 -- range of possible stored values (i.e. it is chosen on the basis
6617 -- of the size of the type, not the range of the values). We write
6618 -- this as two tests, rather than a range check, so that static
6619 -- evaluation will easily remove either or both of the checks if
6620 -- they can be -statically determined to be true (this happens
6621 -- when the type of X is static and the range extends to the full
6622 -- range of stored values).
6624 -- Unsigned types. Note: it is safe to consider only whether the
6625 -- subtype is unsigned, since we will in that case be doing all
6626 -- unsigned comparisons based on the subtype range. Since we use the
6627 -- actual subtype object size, this is appropriate.
6629 -- For example, if we have
6631 -- subtype x is integer range 1 .. 200;
6632 -- for x'Object_Size use 8;
6634 -- Now the base type is signed, but objects of this type are bits
6635 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6636 -- correct, even though a value greater than 127 looks signed to a
6637 -- signed comparison.
6639 elsif Is_Unsigned_Type
(Ptyp
) then
6640 if Esize
(Ptyp
) <= 32 then
6641 Btyp
:= RTE
(RE_Unsigned_32
);
6643 Btyp
:= RTE
(RE_Unsigned_64
);
6646 Rewrite
(N
, Make_Range_Test
);
6651 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6652 Btyp
:= Standard_Integer
;
6654 Btyp
:= Universal_Integer
;
6657 Rewrite
(N
, Make_Range_Test
);
6660 -- If a predicate is present, then we do the predicate test, even if
6661 -- within the predicate function (infinite recursion is warned about
6662 -- in Sem_Attr in that case).
6665 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6668 if Present
(Pred_Func
) then
6671 Left_Opnd
=> Relocate_Node
(N
),
6672 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6676 Analyze_And_Resolve
(N
, Standard_Boolean
);
6677 Validity_Checks_On
:= Save_Validity_Checks_On
;
6684 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6688 if Present
(Underlying_Type
(Ptyp
)) then
6689 Ftyp
:= Underlying_Type
(Ptyp
);
6694 -- Replace by True if no scalar parts
6696 if not Scalar_Part_Present
(Ftyp
) then
6697 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6699 -- For scalar types, Valid_Scalars is the same as Valid
6701 elsif Is_Scalar_Type
(Ftyp
) then
6703 Make_Attribute_Reference
(Loc
,
6704 Attribute_Name
=> Name_Valid
,
6707 -- For array types, we construct a function that determines if there
6708 -- are any non-valid scalar subcomponents, and call the function.
6709 -- We only do this for arrays whose component type needs checking
6711 elsif Is_Array_Type
(Ftyp
)
6712 and then Scalar_Part_Present
(Component_Type
(Ftyp
))
6715 Make_Function_Call
(Loc
,
6717 New_Occurrence_Of
(Build_Array_VS_Func
(Ftyp
, N
), Loc
),
6718 Parameter_Associations
=> New_List
(Pref
)));
6720 -- For record types, we construct a function that determines if there
6721 -- are any non-valid scalar subcomponents, and call the function.
6723 elsif Is_Record_Type
(Ftyp
)
6724 and then Nkind
(Type_Definition
(Declaration_Node
(Ftyp
))) =
6728 Make_Function_Call
(Loc
,
6730 New_Occurrence_Of
(Build_Record_VS_Func
(Ftyp
, N
), Loc
),
6731 Parameter_Associations
=> New_List
(Pref
)));
6733 -- Other record types or types with discriminants
6735 elsif Is_Record_Type
(Ftyp
) or else Has_Discriminants
(Ptyp
) then
6737 -- Build expression with list of equality tests
6745 X
:= New_Occurrence_Of
(Standard_True
, Loc
);
6746 C
:= First_Component_Or_Discriminant
(Ptyp
);
6747 while Present
(C
) loop
6748 if not Scalar_Part_Present
(Etype
(C
)) then
6750 elsif Is_Scalar_Type
(Etype
(C
)) then
6753 A
:= Name_Valid_Scalars
;
6760 Make_Attribute_Reference
(Loc
,
6761 Attribute_Name
=> A
,
6763 Make_Selected_Component
(Loc
,
6765 Duplicate_Subexpr
(Pref
, Name_Req
=> True),
6767 New_Occurrence_Of
(C
, Loc
))));
6769 Next_Component_Or_Discriminant
(C
);
6775 -- For all other types, result is True
6778 Rewrite
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
6781 -- Result is always boolean, but never static
6783 Analyze_And_Resolve
(N
, Standard_Boolean
);
6784 Set_Is_Static_Expression
(N
, False);
6791 -- Value attribute is handled in separate unit Exp_Imgv
6793 when Attribute_Value
=>
6794 Exp_Imgv
.Expand_Value_Attribute
(N
);
6800 -- The processing for Value_Size shares the processing for Size
6806 -- The processing for Version shares the processing for Body_Version
6812 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6814 when Attribute_Wide_Image
=>
6815 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
6817 ---------------------
6818 -- Wide_Wide_Image --
6819 ---------------------
6821 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6823 when Attribute_Wide_Wide_Image
=>
6824 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
6830 -- We expand typ'Wide_Value (X) into
6833 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6835 -- Wide_String_To_String is a runtime function that converts its wide
6836 -- string argument to String, converting any non-translatable characters
6837 -- into appropriate escape sequences. This preserves the required
6838 -- semantics of Wide_Value in all cases, and results in a very simple
6839 -- implementation approach.
6841 -- Note: for this approach to be fully standard compliant for the cases
6842 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6843 -- method must cover the entire character range (e.g. UTF-8). But that
6844 -- is a reasonable requirement when dealing with encoded character
6845 -- sequences. Presumably if one of the restrictive encoding mechanisms
6846 -- is in use such as Shift-JIS, then characters that cannot be
6847 -- represented using this encoding will not appear in any case.
6849 when Attribute_Wide_Value
=> Wide_Value
:
6852 Make_Attribute_Reference
(Loc
,
6854 Attribute_Name
=> Name_Value
,
6856 Expressions
=> New_List
(
6857 Make_Function_Call
(Loc
,
6859 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
6861 Parameter_Associations
=> New_List
(
6862 Relocate_Node
(First
(Exprs
)),
6863 Make_Integer_Literal
(Loc
,
6864 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6866 Analyze_And_Resolve
(N
, Typ
);
6869 ---------------------
6870 -- Wide_Wide_Value --
6871 ---------------------
6873 -- We expand typ'Wide_Value_Value (X) into
6876 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6878 -- Wide_Wide_String_To_String is a runtime function that converts its
6879 -- wide string argument to String, converting any non-translatable
6880 -- characters into appropriate escape sequences. This preserves the
6881 -- required semantics of Wide_Wide_Value in all cases, and results in a
6882 -- very simple implementation approach.
6884 -- It's not quite right where typ = Wide_Wide_Character, because the
6885 -- encoding method may not cover the whole character type ???
6887 when Attribute_Wide_Wide_Value
=> Wide_Wide_Value
:
6890 Make_Attribute_Reference
(Loc
,
6892 Attribute_Name
=> Name_Value
,
6894 Expressions
=> New_List
(
6895 Make_Function_Call
(Loc
,
6898 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
6900 Parameter_Associations
=> New_List
(
6901 Relocate_Node
(First
(Exprs
)),
6902 Make_Integer_Literal
(Loc
,
6903 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6905 Analyze_And_Resolve
(N
, Typ
);
6906 end Wide_Wide_Value
;
6908 ---------------------
6909 -- Wide_Wide_Width --
6910 ---------------------
6912 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6914 when Attribute_Wide_Wide_Width
=>
6915 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
6921 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6923 when Attribute_Wide_Width
=>
6924 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
6930 -- Width attribute is handled in separate unit Exp_Imgv
6932 when Attribute_Width
=>
6933 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
6939 when Attribute_Write
=> Write
: declare
6940 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6941 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6949 -- If no underlying type, we have an error that will be diagnosed
6950 -- elsewhere, so here we just completely ignore the expansion.
6956 -- Stream operations can appear in user code even if the restriction
6957 -- No_Streams is active (for example, when instantiating a predefined
6958 -- container). In that case rewrite the attribute as a Raise to
6959 -- prevent any run-time use.
6961 if Restriction_Active
(No_Streams
) then
6963 Make_Raise_Program_Error
(Sloc
(N
),
6964 Reason
=> PE_Stream_Operation_Not_Allowed
));
6965 Set_Etype
(N
, U_Type
);
6969 -- The simple case, if there is a TSS for Write, just call it
6971 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
6973 if Present
(Pname
) then
6977 -- If there is a Stream_Convert pragma, use it, we rewrite
6979 -- sourcetyp'Output (stream, Item)
6983 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6985 -- where strmwrite is the given Write function that converts an
6986 -- argument of type sourcetyp or a type acctyp, from which it is
6987 -- derived to type strmtyp. The conversion to acttyp is required
6988 -- for the derived case.
6990 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6992 if Present
(Prag
) then
6994 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
6995 Wfunc
:= Entity
(Expression
(Arg3
));
6998 Make_Attribute_Reference
(Loc
,
6999 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7000 Attribute_Name
=> Name_Output
,
7001 Expressions
=> New_List
(
7002 Relocate_Node
(First
(Exprs
)),
7003 Make_Function_Call
(Loc
,
7004 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7005 Parameter_Associations
=> New_List
(
7006 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7007 Relocate_Node
(Next
(First
(Exprs
)))))))));
7012 -- For elementary types, we call the W_xxx routine directly
7014 elsif Is_Elementary_Type
(U_Type
) then
7015 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
7021 elsif Is_Array_Type
(U_Type
) then
7022 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
7023 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
7025 -- Tagged type case, use the primitive Write function. Note that
7026 -- this will dispatch in the class-wide case which is what we want
7028 elsif Is_Tagged_Type
(U_Type
) then
7029 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
7031 -- All other record type cases, including protected records.
7032 -- The latter only arise for expander generated code for
7033 -- handling shared passive partition access.
7037 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
7039 -- Ada 2005 (AI-216): Program_Error is raised when executing
7040 -- the default implementation of the Write attribute of an
7041 -- Unchecked_Union type. However, if the 'Write reference is
7042 -- within the generated Output stream procedure, Write outputs
7043 -- the components, and the default values of the discriminant
7044 -- are streamed by the Output procedure itself.
7046 if Is_Unchecked_Union
(Base_Type
(U_Type
))
7047 and not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
7050 Make_Raise_Program_Error
(Loc
,
7051 Reason
=> PE_Unchecked_Union_Restriction
));
7054 if Has_Discriminants
(U_Type
)
7056 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
7058 Build_Mutable_Record_Write_Procedure
7059 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7061 Build_Record_Write_Procedure
7062 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
7065 Insert_Action
(N
, Decl
);
7069 -- If we fall through, Pname is the procedure to be called
7071 Rewrite_Stream_Proc_Call
(Pname
);
7074 -- Component_Size is handled by the back end, unless the component size
7075 -- is known at compile time, which is always true in the packed array
7076 -- case. It is important that the packed array case is handled in the
7077 -- front end (see Eval_Attribute) since the back end would otherwise get
7078 -- confused by the equivalent packed array type.
7080 when Attribute_Component_Size
=>
7083 -- The following attributes are handled by the back end (except that
7084 -- static cases have already been evaluated during semantic processing,
7085 -- but in any case the back end should not count on this).
7087 -- The back end also handles the non-class-wide cases of Size
7089 when Attribute_Bit_Order |
7090 Attribute_Code_Address |
7091 Attribute_Definite |
7093 Attribute_Null_Parameter |
7094 Attribute_Passed_By_Reference |
7095 Attribute_Pool_Address |
7096 Attribute_Scalar_Storage_Order
=>
7099 -- The following attributes are also handled by the back end, but return
7100 -- a universal integer result, so may need a conversion for checking
7101 -- that the result is in range.
7103 when Attribute_Aft |
7104 Attribute_Max_Alignment_For_Allocation
=>
7105 Apply_Universal_Integer_Attribute_Checks
(N
);
7107 -- The following attributes should not appear at this stage, since they
7108 -- have already been handled by the analyzer (and properly rewritten
7109 -- with corresponding values or entities to represent the right values)
7111 when Attribute_Abort_Signal |
7112 Attribute_Address_Size |
7113 Attribute_Atomic_Always_Lock_Free |
7116 Attribute_Compiler_Version |
7117 Attribute_Default_Bit_Order |
7118 Attribute_Default_Scalar_Storage_Order |
7125 Attribute_Fast_Math |
7126 Attribute_First_Valid |
7127 Attribute_Has_Access_Values |
7128 Attribute_Has_Discriminants |
7129 Attribute_Has_Tagged_Values |
7131 Attribute_Last_Valid |
7132 Attribute_Library_Level |
7133 Attribute_Lock_Free |
7134 Attribute_Machine_Emax |
7135 Attribute_Machine_Emin |
7136 Attribute_Machine_Mantissa |
7137 Attribute_Machine_Overflows |
7138 Attribute_Machine_Radix |
7139 Attribute_Machine_Rounds |
7140 Attribute_Maximum_Alignment |
7141 Attribute_Model_Emin |
7142 Attribute_Model_Epsilon |
7143 Attribute_Model_Mantissa |
7144 Attribute_Model_Small |
7146 Attribute_Partition_ID |
7148 Attribute_Restriction_Set |
7149 Attribute_Safe_Emax |
7150 Attribute_Safe_First |
7151 Attribute_Safe_Large |
7152 Attribute_Safe_Last |
7153 Attribute_Safe_Small |
7155 Attribute_Signed_Zeros |
7157 Attribute_Storage_Unit |
7158 Attribute_Stub_Type |
7159 Attribute_System_Allocator_Alignment |
7160 Attribute_Target_Name |
7161 Attribute_Type_Class |
7162 Attribute_Type_Key |
7163 Attribute_Unconstrained_Array |
7164 Attribute_Universal_Literal_String |
7165 Attribute_Wchar_T_Size |
7166 Attribute_Word_Size
=>
7167 raise Program_Error
;
7169 -- The Asm_Input and Asm_Output attributes are not expanded at this
7170 -- stage, but will be eliminated in the expansion of the Asm call, see
7171 -- Exp_Intr for details. So the back end will never see these either.
7173 when Attribute_Asm_Input |
7174 Attribute_Asm_Output
=>
7178 -- Note: as mentioned earlier, individual sections of the above case
7179 -- statement assume there is no code after the case statement, and are
7180 -- legitimately allowed to execute return statements if they have nothing
7181 -- more to do, so DO NOT add code at this point.
7184 when RE_Not_Available
=>
7186 end Expand_N_Attribute_Reference
;
7188 --------------------------------
7189 -- Expand_Pred_Succ_Attribute --
7190 --------------------------------
7192 -- For typ'Pred (exp), we generate the check
7194 -- [constraint_error when exp = typ'Base'First]
7196 -- Similarly, for typ'Succ (exp), we generate the check
7198 -- [constraint_error when exp = typ'Base'Last]
7200 -- These checks are not generated for modular types, since the proper
7201 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7202 -- We also suppress these checks if we are the right side of an assignment
7203 -- statement or the expression of an object declaration, where the flag
7204 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7206 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
7207 Loc
: constant Source_Ptr
:= Sloc
(N
);
7208 P
: constant Node_Id
:= Parent
(N
);
7212 if Attribute_Name
(N
) = Name_Pred
then
7218 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
7219 or else not Suppress_Assignment_Checks
(P
)
7222 Make_Raise_Constraint_Error
(Loc
,
7226 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
7228 Make_Attribute_Reference
(Loc
,
7230 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
7231 Attribute_Name
=> Cnam
)),
7232 Reason
=> CE_Overflow_Check_Failed
));
7234 end Expand_Pred_Succ_Attribute
;
7236 -----------------------------
7237 -- Expand_Update_Attribute --
7238 -----------------------------
7240 procedure Expand_Update_Attribute
(N
: Node_Id
) is
7241 procedure Process_Component_Or_Element_Update
7246 -- Generate the statements necessary to update a single component or an
7247 -- element of the prefix. The code is inserted before the attribute N.
7248 -- Temp denotes the entity of the anonymous object created to reflect
7249 -- the changes in values. Comp is the component/index expression to be
7250 -- updated. Expr is an expression yielding the new value of Comp. Typ
7251 -- is the type of the prefix of attribute Update.
7253 procedure Process_Range_Update
7258 -- Generate the statements necessary to update a slice of the prefix.
7259 -- The code is inserted before the attribute N. Temp denotes the entity
7260 -- of the anonymous object created to reflect the changes in values.
7261 -- Comp is range of the slice to be updated. Expr is an expression
7262 -- yielding the new value of Comp. Typ is the type of the prefix of
7263 -- attribute Update.
7265 -----------------------------------------
7266 -- Process_Component_Or_Element_Update --
7267 -----------------------------------------
7269 procedure Process_Component_Or_Element_Update
7275 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7280 -- An array element may be modified by the following relations
7281 -- depending on the number of dimensions:
7283 -- 1 => Expr -- one dimensional update
7284 -- (1, ..., N) => Expr -- multi dimensional update
7286 -- The above forms are converted in assignment statements where the
7287 -- left hand side is an indexed component:
7289 -- Temp (1) := Expr; -- one dimensional update
7290 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7292 if Is_Array_Type
(Typ
) then
7294 -- The index expressions of a multi dimensional array update
7295 -- appear as an aggregate.
7297 if Nkind
(Comp
) = N_Aggregate
then
7298 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
7300 Exprs
:= New_List
(Relocate_Node
(Comp
));
7304 Make_Indexed_Component
(Loc
,
7305 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7306 Expressions
=> Exprs
);
7308 -- A record component update appears in the following form:
7312 -- The above relation is transformed into an assignment statement
7313 -- where the left hand side is a selected component:
7315 -- Temp.Comp := Expr;
7317 else pragma Assert
(Is_Record_Type
(Typ
));
7319 Make_Selected_Component
(Loc
,
7320 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7321 Selector_Name
=> Relocate_Node
(Comp
));
7325 Make_Assignment_Statement
(Loc
,
7327 Expression
=> Relocate_Node
(Expr
)));
7328 end Process_Component_Or_Element_Update
;
7330 --------------------------
7331 -- Process_Range_Update --
7332 --------------------------
7334 procedure Process_Range_Update
7340 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
7341 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
7345 -- A range update appears as
7347 -- (Low .. High => Expr)
7349 -- The above construct is transformed into a loop that iterates over
7350 -- the given range and modifies the corresponding array values to the
7353 -- for Index in Low .. High loop
7354 -- Temp (<Index_Typ> (Index)) := Expr;
7357 Index
:= Make_Temporary
(Loc
, 'I');
7360 Make_Loop_Statement
(Loc
,
7362 Make_Iteration_Scheme
(Loc
,
7363 Loop_Parameter_Specification
=>
7364 Make_Loop_Parameter_Specification
(Loc
,
7365 Defining_Identifier
=> Index
,
7366 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
7368 Statements
=> New_List
(
7369 Make_Assignment_Statement
(Loc
,
7371 Make_Indexed_Component
(Loc
,
7372 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
7373 Expressions
=> New_List
(
7374 Convert_To
(Index_Typ
,
7375 New_Occurrence_Of
(Index
, Loc
)))),
7376 Expression
=> Relocate_Node
(Expr
))),
7378 End_Label
=> Empty
));
7379 end Process_Range_Update
;
7383 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
7384 Loc
: constant Source_Ptr
:= Sloc
(N
);
7385 Pref
: constant Node_Id
:= Prefix
(N
);
7386 Typ
: constant Entity_Id
:= Etype
(Pref
);
7389 CW_Temp
: Entity_Id
;
7394 -- Start of processing for Expand_Update_Attribute
7397 -- Create the anonymous object to store the value of the prefix and
7398 -- capture subsequent changes in value.
7400 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
7402 -- Preserve the tag of the prefix by offering a specific view of the
7403 -- class-wide version of the prefix.
7405 if Is_Tagged_Type
(Typ
) then
7408 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7410 CW_Temp
:= Make_Temporary
(Loc
, 'T');
7411 CW_Typ
:= Class_Wide_Type
(Typ
);
7414 Make_Object_Declaration
(Loc
,
7415 Defining_Identifier
=> CW_Temp
,
7416 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
7418 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
7421 -- Temp : Typ renames Typ (CW_Temp);
7424 Make_Object_Renaming_Declaration
(Loc
,
7425 Defining_Identifier
=> Temp
,
7426 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
7428 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
7434 -- Temp : Typ := Pref;
7437 Make_Object_Declaration
(Loc
,
7438 Defining_Identifier
=> Temp
,
7439 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
7440 Expression
=> Relocate_Node
(Pref
)));
7443 -- Process the update aggregate
7445 Assoc
:= First
(Component_Associations
(Aggr
));
7446 while Present
(Assoc
) loop
7447 Comp
:= First
(Choices
(Assoc
));
7448 Expr
:= Expression
(Assoc
);
7449 while Present
(Comp
) loop
7450 if Nkind
(Comp
) = N_Range
then
7451 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
7453 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
7462 -- The attribute is replaced by a reference to the anonymous object
7464 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
7466 end Expand_Update_Attribute
;
7472 procedure Find_Fat_Info
7474 Fat_Type
: out Entity_Id
;
7475 Fat_Pkg
: out RE_Id
)
7477 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
7480 -- All we do is use the root type (historically this dealt with
7481 -- VAX-float .. to be cleaned up further later ???)
7485 if Fat_Type
= Standard_Short_Float
then
7486 Fat_Pkg
:= RE_Attr_Short_Float
;
7488 elsif Fat_Type
= Standard_Float
then
7489 Fat_Pkg
:= RE_Attr_Float
;
7491 elsif Fat_Type
= Standard_Long_Float
then
7492 Fat_Pkg
:= RE_Attr_Long_Float
;
7494 elsif Fat_Type
= Standard_Long_Long_Float
then
7495 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7497 -- Universal real (which is its own root type) is treated as being
7498 -- equivalent to Standard.Long_Long_Float, since it is defined to
7499 -- have the same precision as the longest Float type.
7501 elsif Fat_Type
= Universal_Real
then
7502 Fat_Type
:= Standard_Long_Long_Float
;
7503 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7506 raise Program_Error
;
7510 ----------------------------
7511 -- Find_Stream_Subprogram --
7512 ----------------------------
7514 function Find_Stream_Subprogram
7516 Nam
: TSS_Name_Type
) return Entity_Id
7518 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7519 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
7521 function Is_Available
(Entity
: RE_Id
) return Boolean;
7522 pragma Inline
(Is_Available
);
7523 -- Function to check whether the specified run-time call is available
7524 -- in the run time used. In the case of a configurable run time, it
7525 -- is normal that some subprograms are not there.
7527 -- I don't understand this routine at all, why is this not just a
7528 -- call to RTE_Available? And if for some reason we need a different
7529 -- routine with different semantics, why is not in Rtsfind ???
7535 function Is_Available
(Entity
: RE_Id
) return Boolean is
7537 -- Assume that the unit will always be available when using a
7538 -- "normal" (not configurable) run time.
7540 return not Configurable_Run_Time_Mode
or else RTE_Available
(Entity
);
7543 -- Start of processing for Find_Stream_Subprogram
7546 if Present
(Ent
) then
7550 -- Stream attributes for strings are expanded into library calls. The
7551 -- following checks are disabled when the run-time is not available or
7552 -- when compiling predefined types due to bootstrap issues. As a result,
7553 -- the compiler will generate in-place stream routines for string types
7554 -- that appear in GNAT's library, but will generate calls via rtsfind
7555 -- to library routines for user code.
7557 -- ??? For now, disable this code for JVM, since this generates a
7558 -- VerifyError exception at run time on e.g. c330001.
7560 -- This is disabled for AAMP, to avoid creating dependences on files not
7561 -- supported in the AAMP library (such as s-fileio.adb).
7563 -- Note: In the case of using a configurable run time, it is very likely
7564 -- that stream routines for string types are not present (they require
7565 -- file system support). In this case, the specific stream routines for
7566 -- strings are not used, relying on the regular stream mechanism
7567 -- instead. That is why we include the test Is_Available when dealing
7568 -- with these cases.
7570 if VM_Target
/= JVM_Target
7571 and then not AAMP_On_Target
7573 not Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
7575 -- Storage_Array as defined in package System.Storage_Elements
7577 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
7579 -- Case of No_Stream_Optimizations restriction active
7581 if Restriction_Active
(No_Stream_Optimizations
) then
7582 if Nam
= TSS_Stream_Input
7583 and then Is_Available
(RE_Storage_Array_Input
)
7585 return RTE
(RE_Storage_Array_Input
);
7587 elsif Nam
= TSS_Stream_Output
7588 and then Is_Available
(RE_Storage_Array_Output
)
7590 return RTE
(RE_Storage_Array_Output
);
7592 elsif Nam
= TSS_Stream_Read
7593 and then Is_Available
(RE_Storage_Array_Read
)
7595 return RTE
(RE_Storage_Array_Read
);
7597 elsif Nam
= TSS_Stream_Write
7598 and then Is_Available
(RE_Storage_Array_Write
)
7600 return RTE
(RE_Storage_Array_Write
);
7602 elsif Nam
/= TSS_Stream_Input
and then
7603 Nam
/= TSS_Stream_Output
and then
7604 Nam
/= TSS_Stream_Read
and then
7605 Nam
/= TSS_Stream_Write
7607 raise Program_Error
;
7610 -- Restriction No_Stream_Optimizations is not set, so we can go
7611 -- ahead and optimize using the block IO forms of the routines.
7614 if Nam
= TSS_Stream_Input
7615 and then Is_Available
(RE_Storage_Array_Input_Blk_IO
)
7617 return RTE
(RE_Storage_Array_Input_Blk_IO
);
7619 elsif Nam
= TSS_Stream_Output
7620 and then Is_Available
(RE_Storage_Array_Output_Blk_IO
)
7622 return RTE
(RE_Storage_Array_Output_Blk_IO
);
7624 elsif Nam
= TSS_Stream_Read
7625 and then Is_Available
(RE_Storage_Array_Read_Blk_IO
)
7627 return RTE
(RE_Storage_Array_Read_Blk_IO
);
7629 elsif Nam
= TSS_Stream_Write
7630 and then Is_Available
(RE_Storage_Array_Write_Blk_IO
)
7632 return RTE
(RE_Storage_Array_Write_Blk_IO
);
7634 elsif Nam
/= TSS_Stream_Input
and then
7635 Nam
/= TSS_Stream_Output
and then
7636 Nam
/= TSS_Stream_Read
and then
7637 Nam
/= TSS_Stream_Write
7639 raise Program_Error
;
7643 -- Stream_Element_Array as defined in package Ada.Streams
7645 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
7647 -- Case of No_Stream_Optimizations restriction active
7649 if Restriction_Active
(No_Stream_Optimizations
) then
7650 if Nam
= TSS_Stream_Input
7651 and then Is_Available
(RE_Stream_Element_Array_Input
)
7653 return RTE
(RE_Stream_Element_Array_Input
);
7655 elsif Nam
= TSS_Stream_Output
7656 and then Is_Available
(RE_Stream_Element_Array_Output
)
7658 return RTE
(RE_Stream_Element_Array_Output
);
7660 elsif Nam
= TSS_Stream_Read
7661 and then Is_Available
(RE_Stream_Element_Array_Read
)
7663 return RTE
(RE_Stream_Element_Array_Read
);
7665 elsif Nam
= TSS_Stream_Write
7666 and then Is_Available
(RE_Stream_Element_Array_Write
)
7668 return RTE
(RE_Stream_Element_Array_Write
);
7670 elsif Nam
/= TSS_Stream_Input
and then
7671 Nam
/= TSS_Stream_Output
and then
7672 Nam
/= TSS_Stream_Read
and then
7673 Nam
/= TSS_Stream_Write
7675 raise Program_Error
;
7678 -- Restriction No_Stream_Optimizations is not set, so we can go
7679 -- ahead and optimize using the block IO forms of the routines.
7682 if Nam
= TSS_Stream_Input
7683 and then Is_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
7685 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
7687 elsif Nam
= TSS_Stream_Output
7688 and then Is_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
7690 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
7692 elsif Nam
= TSS_Stream_Read
7693 and then Is_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
7695 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
7697 elsif Nam
= TSS_Stream_Write
7698 and then Is_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
7700 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
7702 elsif Nam
/= TSS_Stream_Input
and then
7703 Nam
/= TSS_Stream_Output
and then
7704 Nam
/= TSS_Stream_Read
and then
7705 Nam
/= TSS_Stream_Write
7707 raise Program_Error
;
7711 -- String as defined in package Ada
7713 elsif Base_Typ
= Standard_String
then
7715 -- Case of No_Stream_Optimizations restriction active
7717 if Restriction_Active
(No_Stream_Optimizations
) then
7718 if Nam
= TSS_Stream_Input
7719 and then Is_Available
(RE_String_Input
)
7721 return RTE
(RE_String_Input
);
7723 elsif Nam
= TSS_Stream_Output
7724 and then Is_Available
(RE_String_Output
)
7726 return RTE
(RE_String_Output
);
7728 elsif Nam
= TSS_Stream_Read
7729 and then Is_Available
(RE_String_Read
)
7731 return RTE
(RE_String_Read
);
7733 elsif Nam
= TSS_Stream_Write
7734 and then Is_Available
(RE_String_Write
)
7736 return RTE
(RE_String_Write
);
7738 elsif Nam
/= TSS_Stream_Input
and then
7739 Nam
/= TSS_Stream_Output
and then
7740 Nam
/= TSS_Stream_Read
and then
7741 Nam
/= TSS_Stream_Write
7743 raise Program_Error
;
7746 -- Restriction No_Stream_Optimizations is not set, so we can go
7747 -- ahead and optimize using the block IO forms of the routines.
7750 if Nam
= TSS_Stream_Input
7751 and then Is_Available
(RE_String_Input_Blk_IO
)
7753 return RTE
(RE_String_Input_Blk_IO
);
7755 elsif Nam
= TSS_Stream_Output
7756 and then Is_Available
(RE_String_Output_Blk_IO
)
7758 return RTE
(RE_String_Output_Blk_IO
);
7760 elsif Nam
= TSS_Stream_Read
7761 and then Is_Available
(RE_String_Read_Blk_IO
)
7763 return RTE
(RE_String_Read_Blk_IO
);
7765 elsif Nam
= TSS_Stream_Write
7766 and then Is_Available
(RE_String_Write_Blk_IO
)
7768 return RTE
(RE_String_Write_Blk_IO
);
7770 elsif Nam
/= TSS_Stream_Input
and then
7771 Nam
/= TSS_Stream_Output
and then
7772 Nam
/= TSS_Stream_Read
and then
7773 Nam
/= TSS_Stream_Write
7775 raise Program_Error
;
7779 -- Wide_String as defined in package Ada
7781 elsif Base_Typ
= Standard_Wide_String
then
7783 -- Case of No_Stream_Optimizations restriction active
7785 if Restriction_Active
(No_Stream_Optimizations
) then
7786 if Nam
= TSS_Stream_Input
7787 and then Is_Available
(RE_Wide_String_Input
)
7789 return RTE
(RE_Wide_String_Input
);
7791 elsif Nam
= TSS_Stream_Output
7792 and then Is_Available
(RE_Wide_String_Output
)
7794 return RTE
(RE_Wide_String_Output
);
7796 elsif Nam
= TSS_Stream_Read
7797 and then Is_Available
(RE_Wide_String_Read
)
7799 return RTE
(RE_Wide_String_Read
);
7801 elsif Nam
= TSS_Stream_Write
7802 and then Is_Available
(RE_Wide_String_Write
)
7804 return RTE
(RE_Wide_String_Write
);
7806 elsif Nam
/= TSS_Stream_Input
and then
7807 Nam
/= TSS_Stream_Output
and then
7808 Nam
/= TSS_Stream_Read
and then
7809 Nam
/= TSS_Stream_Write
7811 raise Program_Error
;
7814 -- Restriction No_Stream_Optimizations is not set, so we can go
7815 -- ahead and optimize using the block IO forms of the routines.
7818 if Nam
= TSS_Stream_Input
7819 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
7821 return RTE
(RE_Wide_String_Input_Blk_IO
);
7823 elsif Nam
= TSS_Stream_Output
7824 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
7826 return RTE
(RE_Wide_String_Output_Blk_IO
);
7828 elsif Nam
= TSS_Stream_Read
7829 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
7831 return RTE
(RE_Wide_String_Read_Blk_IO
);
7833 elsif Nam
= TSS_Stream_Write
7834 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
7836 return RTE
(RE_Wide_String_Write_Blk_IO
);
7838 elsif Nam
/= TSS_Stream_Input
and then
7839 Nam
/= TSS_Stream_Output
and then
7840 Nam
/= TSS_Stream_Read
and then
7841 Nam
/= TSS_Stream_Write
7843 raise Program_Error
;
7847 -- Wide_Wide_String as defined in package Ada
7849 elsif Base_Typ
= Standard_Wide_Wide_String
then
7851 -- Case of No_Stream_Optimizations restriction active
7853 if Restriction_Active
(No_Stream_Optimizations
) then
7854 if Nam
= TSS_Stream_Input
7855 and then Is_Available
(RE_Wide_Wide_String_Input
)
7857 return RTE
(RE_Wide_Wide_String_Input
);
7859 elsif Nam
= TSS_Stream_Output
7860 and then Is_Available
(RE_Wide_Wide_String_Output
)
7862 return RTE
(RE_Wide_Wide_String_Output
);
7864 elsif Nam
= TSS_Stream_Read
7865 and then Is_Available
(RE_Wide_Wide_String_Read
)
7867 return RTE
(RE_Wide_Wide_String_Read
);
7869 elsif Nam
= TSS_Stream_Write
7870 and then Is_Available
(RE_Wide_Wide_String_Write
)
7872 return RTE
(RE_Wide_Wide_String_Write
);
7874 elsif Nam
/= TSS_Stream_Input
and then
7875 Nam
/= TSS_Stream_Output
and then
7876 Nam
/= TSS_Stream_Read
and then
7877 Nam
/= TSS_Stream_Write
7879 raise Program_Error
;
7882 -- Restriction No_Stream_Optimizations is not set, so we can go
7883 -- ahead and optimize using the block IO forms of the routines.
7886 if Nam
= TSS_Stream_Input
7887 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
7889 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
7891 elsif Nam
= TSS_Stream_Output
7892 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
7894 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
7896 elsif Nam
= TSS_Stream_Read
7897 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
7899 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
7901 elsif Nam
= TSS_Stream_Write
7902 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
7904 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
7906 elsif Nam
/= TSS_Stream_Input
and then
7907 Nam
/= TSS_Stream_Output
and then
7908 Nam
/= TSS_Stream_Read
and then
7909 Nam
/= TSS_Stream_Write
7911 raise Program_Error
;
7917 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7918 return Find_Prim_Op
(Typ
, Nam
);
7920 return Find_Inherited_TSS
(Typ
, Nam
);
7922 end Find_Stream_Subprogram
;
7928 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
7932 BT
:= Base_Type
(T
);
7934 if Is_Private_Type
(BT
)
7935 and then Present
(Full_View
(BT
))
7937 BT
:= Full_View
(BT
);
7943 -----------------------
7944 -- Get_Index_Subtype --
7945 -----------------------
7947 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
7948 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
7953 if Is_Access_Type
(P_Type
) then
7954 P_Type
:= Designated_Type
(P_Type
);
7957 if No
(Expressions
(N
)) then
7960 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
7963 Indx
:= First_Index
(P_Type
);
7969 return Etype
(Indx
);
7970 end Get_Index_Subtype
;
7972 -------------------------------
7973 -- Get_Stream_Convert_Pragma --
7974 -------------------------------
7976 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
7981 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7982 -- that a stream convert pragma for a tagged type is not inherited from
7983 -- its parent. Probably what is wrong here is that it is basically
7984 -- incorrect to consider a stream convert pragma to be a representation
7985 -- pragma at all ???
7987 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
7988 while Present
(N
) loop
7989 if Nkind
(N
) = N_Pragma
7990 and then Pragma_Name
(N
) = Name_Stream_Convert
7992 -- For tagged types this pragma is not inherited, so we
7993 -- must verify that it is defined for the given type and
7997 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
7999 if not Is_Tagged_Type
(T
)
8001 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
8011 end Get_Stream_Convert_Pragma
;
8013 ---------------------------------
8014 -- Is_Constrained_Packed_Array --
8015 ---------------------------------
8017 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
8018 Arr
: Entity_Id
:= Typ
;
8021 if Is_Access_Type
(Arr
) then
8022 Arr
:= Designated_Type
(Arr
);
8025 return Is_Array_Type
(Arr
)
8026 and then Is_Constrained
(Arr
)
8027 and then Present
(Packed_Array_Impl_Type
(Arr
));
8028 end Is_Constrained_Packed_Array
;
8030 ----------------------------------------
8031 -- Is_Inline_Floating_Point_Attribute --
8032 ----------------------------------------
8034 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
8035 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8037 function Is_GCC_Target
return Boolean;
8038 -- Return True if we are using a GCC target/back-end
8039 -- ??? Note: the implementation is kludgy/fragile
8045 function Is_GCC_Target
return Boolean is
8047 return VM_Target
= No_VM
and then not CodePeer_Mode
8048 and then not AAMP_On_Target
;
8051 -- Start of processing for Exp_Attr
8054 -- Machine and Model can be expanded by the GCC backend only
8056 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
8057 return Is_GCC_Target
;
8059 -- Remaining cases handled by all back ends are Rounding and Truncation
8060 -- when appearing as the operand of a conversion to some integer type.
8062 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
8063 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
8068 -- Here we are in the integer conversion context
8070 -- Very probably we should also recognize the cases of Machine_Rounding
8071 -- and unbiased rounding in this conversion context, but the back end is
8072 -- not yet prepared to handle these cases ???
8074 return Id
= Attribute_Rounding
or else Id
= Attribute_Truncation
;
8075 end Is_Inline_Floating_Point_Attribute
;