1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Exp_Atag
; use Exp_Atag
;
31 with Exp_Ch2
; use Exp_Ch2
;
32 with Exp_Ch3
; use Exp_Ch3
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch9
; use Exp_Ch9
;
35 with Exp_Dist
; use Exp_Dist
;
36 with Exp_Imgv
; use Exp_Imgv
;
37 with Exp_Pakd
; use Exp_Pakd
;
38 with Exp_Strm
; use Exp_Strm
;
39 with Exp_Tss
; use Exp_Tss
;
40 with Exp_Util
; use Exp_Util
;
41 with Exp_VFpt
; use Exp_VFpt
;
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 procedure Compile_Stream_Body_In_Scope
92 -- The body for a stream subprogram may be generated outside of the scope
93 -- of the type. If the type is fully private, it may depend on the full
94 -- view of other types (e.g. indexes) that are currently private as well.
95 -- We install the declarations of the package in which the type is declared
96 -- before compiling the body in what is its proper environment. The Check
97 -- parameter indicates if checks are to be suppressed for the stream body.
98 -- We suppress checks for array/record reads, since the rule is that these
99 -- are like assignments, out of range values due to uninitialized storage,
100 -- or other invalid values do NOT cause a Constraint_Error to be raised.
102 procedure Expand_Access_To_Protected_Op
106 -- An attribute reference to a protected subprogram is transformed into
107 -- a pair of pointers: one to the object, and one to the operations.
108 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
110 procedure Expand_Fpt_Attribute
115 -- This procedure expands a call to a floating-point attribute function.
116 -- N is the attribute reference node, and Args is a list of arguments to
117 -- be passed to the function call. Pkg identifies the package containing
118 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
119 -- have already been converted to the floating-point type for which Pkg was
120 -- instantiated. The Nam argument is the relevant attribute processing
121 -- routine to be called. This is the same as the attribute name, except in
122 -- the Unaligned_Valid case.
124 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
125 -- This procedure expands a call to a floating-point attribute function
126 -- that takes a single floating-point argument. The function to be called
127 -- is always the same as the attribute name.
129 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
130 -- This procedure expands a call to a floating-point attribute function
131 -- that takes one floating-point argument and one integer argument. The
132 -- function to be called is always the same as the attribute name.
134 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
135 -- This procedure expands a call to a floating-point attribute function
136 -- that takes two floating-point arguments. The function to be called
137 -- is always the same as the attribute name.
139 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
140 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
141 -- loop may be converted into a conditional block. See body for details.
143 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
144 -- Handle the expansion of attributes 'Max and 'Min, including expanding
145 -- then out if we are in Modify_Tree_For_C mode.
147 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
148 -- Handles expansion of Pred or Succ attributes for case of non-real
149 -- operand with overflow checking required.
151 procedure Expand_Update_Attribute
(N
: Node_Id
);
152 -- Handle the expansion of attribute Update
154 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
155 -- Used for Last, Last, and Length, when the prefix is an array type.
156 -- Obtains the corresponding index subtype.
158 procedure Find_Fat_Info
160 Fat_Type
: out Entity_Id
;
161 Fat_Pkg
: out RE_Id
);
162 -- Given a floating-point type T, identifies the package containing the
163 -- attributes for this type (returned in Fat_Pkg), and the corresponding
164 -- type for which this package was instantiated from Fat_Gen. Error if T
165 -- is not a floating-point type.
167 function Find_Stream_Subprogram
169 Nam
: TSS_Name_Type
) return Entity_Id
;
170 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
171 -- types, the corresponding primitive operation is looked up, else the
172 -- appropriate TSS from the type itself, or from its closest ancestor
173 -- defining it, is returned. In both cases, inheritance of representation
174 -- aspects is thus taken into account.
176 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
177 -- The stream functions need to examine the underlying representation of
178 -- composite types. In some cases T may be non-private but its base type
179 -- is, in which case the function returns the corresponding full view.
181 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
182 -- Given a type, find a corresponding stream convert pragma that applies to
183 -- the implementation base type of this type (Typ). If found, return the
184 -- pragma node, otherwise return Empty if no pragma is found.
186 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
187 -- Utility for array attributes, returns true on packed constrained
188 -- arrays, and on access to same.
190 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
191 -- Returns true iff the given node refers to an attribute call that
192 -- can be expanded directly by the back end and does not need front end
193 -- expansion. Typically used for rounding and truncation attributes that
194 -- appear directly inside a conversion to integer.
196 -------------------------
197 -- Build_Array_VS_Func --
198 -------------------------
200 function Build_Array_VS_Func
202 Nod
: Node_Id
) return Entity_Id
204 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
205 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
206 Body_Stmts
: List_Id
;
207 Index_List
: List_Id
;
211 function Test_Component
return List_Id
;
212 -- Create one statement to test validity of one component designated by
213 -- a full set of indexes. Returns statement list containing test.
215 function Test_One_Dimension
(N
: Int
) return List_Id
;
216 -- Create loop to test one dimension of the array. The single statement
217 -- in the loop body tests the inner dimensions if any, or else the
218 -- single component. Note that this procedure is called recursively,
219 -- with N being the dimension to be initialized. A call with N greater
220 -- than the number of dimensions simply generates the component test,
221 -- terminating the recursion. Returns statement list containing tests.
227 function Test_Component
return List_Id
is
233 Make_Indexed_Component
(Loc
,
234 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
235 Expressions
=> Index_List
);
237 if Is_Scalar_Type
(Comp_Type
) then
240 Anam
:= Name_Valid_Scalars
;
244 Make_If_Statement
(Loc
,
248 Make_Attribute_Reference
(Loc
,
249 Attribute_Name
=> Anam
,
251 Then_Statements
=> New_List
(
252 Make_Simple_Return_Statement
(Loc
,
253 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
256 ------------------------
257 -- Test_One_Dimension --
258 ------------------------
260 function Test_One_Dimension
(N
: Int
) return List_Id
is
264 -- If all dimensions dealt with, we simply test the component
266 if N
> Number_Dimensions
(A_Type
) then
267 return Test_Component
;
269 -- Here we generate the required loop
273 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
275 Append
(New_Occurrence_Of
(Index
, Loc
), Index_List
);
278 Make_Implicit_Loop_Statement
(Nod
,
281 Make_Iteration_Scheme
(Loc
,
282 Loop_Parameter_Specification
=>
283 Make_Loop_Parameter_Specification
(Loc
,
284 Defining_Identifier
=> Index
,
285 Discrete_Subtype_Definition
=>
286 Make_Attribute_Reference
(Loc
,
287 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
288 Attribute_Name
=> Name_Range
,
289 Expressions
=> New_List
(
290 Make_Integer_Literal
(Loc
, N
))))),
291 Statements
=> Test_One_Dimension
(N
+ 1)),
292 Make_Simple_Return_Statement
(Loc
,
293 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
295 end Test_One_Dimension
;
297 -- Start of processing for Build_Array_VS_Func
300 Index_List
:= New_List
;
301 Func_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
303 Body_Stmts
:= Test_One_Dimension
(1);
305 -- Parameter is always (A : A_Typ)
307 Formals
:= New_List
(
308 Make_Parameter_Specification
(Loc
,
309 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uA
),
311 Out_Present
=> False,
312 Parameter_Type
=> New_Occurrence_Of
(A_Type
, Loc
)));
316 Set_Ekind
(Func_Id
, E_Function
);
317 Set_Is_Internal
(Func_Id
);
320 Make_Subprogram_Body
(Loc
,
322 Make_Function_Specification
(Loc
,
323 Defining_Unit_Name
=> Func_Id
,
324 Parameter_Specifications
=> Formals
,
326 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
327 Declarations
=> New_List
,
328 Handled_Statement_Sequence
=>
329 Make_Handled_Sequence_Of_Statements
(Loc
,
330 Statements
=> Body_Stmts
)));
332 if not Debug_Generated_Code
then
333 Set_Debug_Info_Off
(Func_Id
);
337 end Build_Array_VS_Func
;
339 ----------------------------------
340 -- Compile_Stream_Body_In_Scope --
341 ----------------------------------
343 procedure Compile_Stream_Body_In_Scope
349 Installed
: Boolean := False;
350 Scop
: constant Entity_Id
:= Scope
(Arr
);
351 Curr
: constant Entity_Id
:= Current_Scope
;
355 and then not In_Open_Scopes
(Scop
)
356 and then Ekind
(Scop
) = E_Package
359 Install_Visible_Declarations
(Scop
);
360 Install_Private_Declarations
(Scop
);
363 -- The entities in the package are now visible, but the generated
364 -- stream entity must appear in the current scope (usually an
365 -- enclosing stream function) so that itypes all have their proper
372 Insert_Action
(N
, Decl
);
374 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
379 -- Remove extra copy of current scope, and package itself
382 End_Package_Scope
(Scop
);
384 end Compile_Stream_Body_In_Scope
;
386 -----------------------------------
387 -- Expand_Access_To_Protected_Op --
388 -----------------------------------
390 procedure Expand_Access_To_Protected_Op
395 -- The value of the attribute_reference is a record containing two
396 -- fields: an access to the protected object, and an access to the
397 -- subprogram itself. The prefix is a selected component.
399 Loc
: constant Source_Ptr
:= Sloc
(N
);
401 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
404 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
405 Acc
: constant Entity_Id
:=
406 Etype
(Next_Component
(First_Component
(E_T
)));
410 function May_Be_External_Call
return Boolean;
411 -- If the 'Access is to a local operation, but appears in a context
412 -- where it may lead to a call from outside the object, we must treat
413 -- this as an external call. Clearly we cannot tell without full
414 -- flow analysis, and a subsequent call that uses this 'Access may
415 -- lead to a bounded error (trying to seize locks twice, e.g.). For
416 -- now we treat 'Access as a potential external call if it is an actual
417 -- in a call to an outside subprogram.
419 --------------------------
420 -- May_Be_External_Call --
421 --------------------------
423 function May_Be_External_Call
return Boolean is
425 Par
: Node_Id
:= Parent
(N
);
428 -- Account for the case where the Access attribute is part of a
429 -- named parameter association.
431 if Nkind
(Par
) = N_Parameter_Association
then
435 if Nkind
(Par
) in N_Subprogram_Call
436 and then Is_Entity_Name
(Name
(Par
))
438 Subp
:= Entity
(Name
(Par
));
439 return not In_Open_Scopes
(Scope
(Subp
));
443 end May_Be_External_Call
;
445 -- Start of processing for Expand_Access_To_Protected_Op
448 -- Within the body of the protected type, the prefix designates a local
449 -- operation, and the object is the first parameter of the corresponding
450 -- protected body of the current enclosing operation.
452 if Is_Entity_Name
(Pref
) then
453 if May_Be_External_Call
then
455 New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
459 (Protected_Body_Subprogram
(Entity
(Pref
)), Loc
);
462 -- Don't traverse the scopes when the attribute occurs within an init
463 -- proc, because we directly use the _init formal of the init proc in
466 Curr
:= Current_Scope
;
467 if not Is_Init_Proc
(Curr
) then
468 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
470 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
471 Curr
:= Scope
(Curr
);
475 -- In case of protected entries the first formal of its Protected_
476 -- Body_Subprogram is the address of the object.
478 if Ekind
(Curr
) = E_Entry
then
482 (Protected_Body_Subprogram
(Curr
)), Loc
);
484 -- If the current scope is an init proc, then use the address of the
485 -- _init formal as the object reference.
487 elsif Is_Init_Proc
(Curr
) then
489 Make_Attribute_Reference
(Loc
,
490 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
491 Attribute_Name
=> Name_Address
);
493 -- In case of protected subprograms the first formal of its
494 -- Protected_Body_Subprogram is the object and we get its address.
498 Make_Attribute_Reference
(Loc
,
502 (Protected_Body_Subprogram
(Curr
)), Loc
),
503 Attribute_Name
=> Name_Address
);
506 -- Case where the prefix is not an entity name. Find the
507 -- version of the protected operation to be called from
508 -- outside the protected object.
514 (Entity
(Selector_Name
(Pref
))), Loc
);
517 Make_Attribute_Reference
(Loc
,
518 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
519 Attribute_Name
=> Name_Address
);
523 Make_Attribute_Reference
(Loc
,
525 Attribute_Name
=> Name_Access
);
527 -- We set the type of the access reference to the already generated
528 -- access_to_subprogram type, and declare the reference analyzed, to
529 -- prevent further expansion when the enclosing aggregate is analyzed.
531 Set_Etype
(Sub_Ref
, Acc
);
532 Set_Analyzed
(Sub_Ref
);
536 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
538 -- Sub_Ref has been marked as analyzed, but we still need to make sure
539 -- Sub is correctly frozen.
541 Freeze_Before
(N
, Entity
(Sub
));
544 Analyze_And_Resolve
(N
, E_T
);
546 -- For subsequent analysis, the node must retain its type. The backend
547 -- will replace it with the equivalent type where needed.
550 end Expand_Access_To_Protected_Op
;
552 --------------------------
553 -- Expand_Fpt_Attribute --
554 --------------------------
556 procedure Expand_Fpt_Attribute
562 Loc
: constant Source_Ptr
:= Sloc
(N
);
563 Typ
: constant Entity_Id
:= Etype
(N
);
567 -- The function name is the selected component Attr_xxx.yyy where
568 -- Attr_xxx is the package name, and yyy is the argument Nam.
570 -- Note: it would be more usual to have separate RE entries for each
571 -- of the entities in the Fat packages, but first they have identical
572 -- names (so we would have to have lots of renaming declarations to
573 -- meet the normal RE rule of separate names for all runtime entities),
574 -- and second there would be an awful lot of them.
577 Make_Selected_Component
(Loc
,
578 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
579 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
581 -- The generated call is given the provided set of parameters, and then
582 -- wrapped in a conversion which converts the result to the target type
583 -- We use the base type as the target because a range check may be
587 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
588 Make_Function_Call
(Loc
,
590 Parameter_Associations
=> Args
)));
592 Analyze_And_Resolve
(N
, Typ
);
593 end Expand_Fpt_Attribute
;
595 ----------------------------
596 -- Expand_Fpt_Attribute_R --
597 ----------------------------
599 -- The single argument is converted to its root type to call the
600 -- appropriate runtime function, with the actual call being built
601 -- by Expand_Fpt_Attribute
603 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
604 E1
: constant Node_Id
:= First
(Expressions
(N
));
608 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
610 (N
, Pkg
, Attribute_Name
(N
),
611 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
612 end Expand_Fpt_Attribute_R
;
614 -----------------------------
615 -- Expand_Fpt_Attribute_RI --
616 -----------------------------
618 -- The first argument is converted to its root type and the second
619 -- argument is converted to standard long long integer to call the
620 -- appropriate runtime function, with the actual call being built
621 -- by Expand_Fpt_Attribute
623 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
624 E1
: constant Node_Id
:= First
(Expressions
(N
));
627 E2
: constant Node_Id
:= Next
(E1
);
629 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
631 (N
, Pkg
, Attribute_Name
(N
),
633 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
634 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
635 end Expand_Fpt_Attribute_RI
;
637 -----------------------------
638 -- Expand_Fpt_Attribute_RR --
639 -----------------------------
641 -- The two arguments are converted to their root types to call the
642 -- appropriate runtime function, with the actual call being built
643 -- by Expand_Fpt_Attribute
645 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
646 E1
: constant Node_Id
:= First
(Expressions
(N
));
647 E2
: constant Node_Id
:= Next
(E1
);
652 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
654 (N
, Pkg
, Attribute_Name
(N
),
656 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
657 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
658 end Expand_Fpt_Attribute_RR
;
660 ---------------------------------
661 -- Expand_Loop_Entry_Attribute --
662 ---------------------------------
664 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
665 procedure Build_Conditional_Block
669 If_Stmt
: out Node_Id
;
670 Blk_Stmt
: out Node_Id
);
671 -- Create a block Blk_Stmt with an empty declarative list and a single
672 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
673 -- condition Cond. If_Stmt is Empty when there is no condition provided.
675 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
676 -- Determine whether loop statement N denotes an Ada 2012 iteration over
679 -----------------------------
680 -- Build_Conditional_Block --
681 -----------------------------
683 procedure Build_Conditional_Block
687 If_Stmt
: out Node_Id
;
688 Blk_Stmt
: out Node_Id
)
691 -- Do not reanalyze the original loop statement because it is simply
694 Set_Analyzed
(Loop_Stmt
);
697 Make_Block_Statement
(Loc
,
698 Declarations
=> New_List
,
699 Handled_Statement_Sequence
=>
700 Make_Handled_Sequence_Of_Statements
(Loc
,
701 Statements
=> New_List
(Loop_Stmt
)));
703 if Present
(Cond
) then
705 Make_If_Statement
(Loc
,
707 Then_Statements
=> New_List
(Blk_Stmt
));
711 end Build_Conditional_Block
;
713 ------------------------
714 -- Is_Array_Iteration --
715 ------------------------
717 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
718 Stmt
: constant Node_Id
:= Original_Node
(N
);
722 if Nkind
(Stmt
) = N_Loop_Statement
723 and then Present
(Iteration_Scheme
(Stmt
))
724 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
726 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
729 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
733 end Is_Array_Iteration
;
737 Exprs
: constant List_Id
:= Expressions
(N
);
738 Pref
: constant Node_Id
:= Prefix
(N
);
739 Typ
: constant Entity_Id
:= Etype
(Pref
);
751 -- Start of processing for Expand_Loop_Entry_Attribute
754 -- Step 1: Find the related loop
756 -- The loop label variant of attribute 'Loop_Entry already has all the
757 -- information in its expression.
759 if Present
(Exprs
) then
760 Loop_Id
:= Entity
(First
(Exprs
));
761 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
763 -- Climb the parent chain to find the nearest enclosing loop. Skip all
764 -- internally generated loops for quantified expressions.
768 while Present
(Loop_Stmt
) loop
769 if Nkind
(Loop_Stmt
) = N_Loop_Statement
770 and then Present
(Identifier
(Loop_Stmt
))
775 Loop_Stmt
:= Parent
(Loop_Stmt
);
778 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
781 Loc
:= Sloc
(Loop_Stmt
);
783 -- Step 2: Transform the loop
785 -- The loop has already been transformed during the expansion of a prior
786 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
788 if Has_Loop_Entry_Attributes
(Loop_Id
) then
790 -- When the related loop name appears as the argument of attribute
791 -- Loop_Entry, the corresponding label construct is the generated
792 -- block statement. This is because the expander reuses the label.
794 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
795 Decls
:= Declarations
(Loop_Stmt
);
797 -- In all other cases, the loop must appear in the handled sequence
798 -- of statements of the generated block.
802 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
803 and then Nkind
(Parent
(Parent
(Loop_Stmt
))) =
806 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
811 -- Transform the loop into a conditional block
814 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
815 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
817 -- Infinite loops are transformed into:
820 -- Temp1 : constant <type of Pref1> := <Pref1>;
822 -- TempN : constant <type of PrefN> := <PrefN>;
825 -- <original source statements with attribute rewrites>
830 Build_Conditional_Block
(Loc
,
832 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
838 -- While loops are transformed into:
840 -- if <Condition> then
842 -- Temp1 : constant <type of Pref1> := <Pref1>;
844 -- TempN : constant <type of PrefN> := <PrefN>;
847 -- <original source statements with attribute rewrites>
848 -- exit when not <Condition>;
853 -- Note that loops over iterators and containers are already
854 -- converted into while loops.
856 elsif Present
(Condition
(Scheme
)) then
858 Cond
: constant Node_Id
:= Condition
(Scheme
);
861 -- Transform the original while loop into an infinite loop
862 -- where the last statement checks the negated condition. This
863 -- placement ensures that the condition will not be evaluated
864 -- twice on the first iteration.
867 -- exit when not <Cond>:
869 Append_To
(Statements
(Loop_Stmt
),
870 Make_Exit_Statement
(Loc
,
871 Condition
=> Make_Op_Not
(Loc
, New_Copy_Tree
(Cond
))));
873 Build_Conditional_Block
(Loc
,
874 Cond
=> Relocate_Node
(Cond
),
875 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
880 -- Ada 2012 iteration over an array is transformed into:
882 -- if <Array_Nam>'Length (1) > 0
883 -- and then <Array_Nam>'Length (N) > 0
886 -- Temp1 : constant <type of Pref1> := <Pref1>;
888 -- TempN : constant <type of PrefN> := <PrefN>;
890 -- for X in ... loop -- multiple loops depending on dims
891 -- <original source statements with attribute rewrites>
896 elsif Is_Array_Iteration
(Loop_Stmt
) then
898 Array_Nam
: constant Entity_Id
:=
899 Entity
(Name
(Iterator_Specification
900 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
901 Num_Dims
: constant Pos
:=
902 Number_Dimensions
(Etype
(Array_Nam
));
903 Cond
: Node_Id
:= Empty
;
907 -- Generate a check which determines whether all dimensions of
908 -- the array are non-null.
910 for Dim
in 1 .. Num_Dims
loop
914 Make_Attribute_Reference
(Loc
,
915 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
916 Attribute_Name
=> Name_Length
,
917 Expressions
=> New_List
(
918 Make_Integer_Literal
(Loc
, Dim
))),
920 Make_Integer_Literal
(Loc
, 0));
928 Right_Opnd
=> Check
);
932 Build_Conditional_Block
(Loc
,
934 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
939 -- For loops are transformed into:
941 -- if <Low> <= <High> then
943 -- Temp1 : constant <type of Pref1> := <Pref1>;
945 -- TempN : constant <type of PrefN> := <PrefN>;
947 -- for <Def_Id> in <Low> .. <High> loop
948 -- <original source statements with attribute rewrites>
953 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
955 Loop_Spec
: constant Node_Id
:=
956 Loop_Parameter_Specification
(Scheme
);
961 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
963 -- When the loop iterates over a subtype indication with a
964 -- range, use the low and high bounds of the subtype itself.
966 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
967 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
970 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
977 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
978 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
980 Build_Conditional_Block
(Loc
,
982 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
988 Decls
:= Declarations
(Blk
);
991 -- Step 3: Create a constant to capture the value of the prefix at the
992 -- entry point into the loop.
995 -- Temp : constant <type of Pref> := <Pref>;
997 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1000 Make_Object_Declaration
(Loc
,
1001 Defining_Identifier
=> Temp_Id
,
1002 Constant_Present
=> True,
1003 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
1004 Expression
=> Relocate_Node
(Pref
));
1005 Append_To
(Decls
, Temp_Decl
);
1007 -- Step 4: Analyze all bits
1009 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1011 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1013 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1014 -- associated loop, ensure the proper visibility for analysis.
1016 if not Installed
then
1017 Push_Scope
(Scope
(Loop_Id
));
1020 -- The analysis of the conditional block takes care of the constant
1023 if Present
(Result
) then
1024 Rewrite
(Loop_Stmt
, Result
);
1025 Analyze
(Loop_Stmt
);
1027 -- The conditional block was analyzed when a previous 'Loop_Entry was
1028 -- expanded. There is no point in reanalyzing the block, simply analyze
1029 -- the declaration of the constant.
1032 Analyze
(Temp_Decl
);
1037 if not Installed
then
1040 end Expand_Loop_Entry_Attribute
;
1042 ------------------------------
1043 -- Expand_Min_Max_Attribute --
1044 ------------------------------
1046 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1048 -- Min and Max are handled by the back end (except that static cases
1049 -- have already been evaluated during semantic processing, although the
1050 -- back end should not count on this). The one bit of special processing
1051 -- required in the normal case is that these two attributes typically
1052 -- generate conditionals in the code, so check the relevant restriction.
1054 Check_Restriction
(No_Implicit_Conditionals
, N
);
1056 -- In Modify_Tree_For_C mode, we rewrite as an if expression
1058 if Modify_Tree_For_C
then
1060 Loc
: constant Source_Ptr
:= Sloc
(N
);
1061 Typ
: constant Entity_Id
:= Etype
(N
);
1062 Expr
: constant Node_Id
:= First
(Expressions
(N
));
1063 Left
: constant Node_Id
:= Relocate_Node
(Expr
);
1064 Right
: constant Node_Id
:= Relocate_Node
(Next
(Expr
));
1066 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
;
1067 -- Returns Left >= Right for Max, Left <= Right for Min
1073 function Make_Compare
(Left
, Right
: Node_Id
) return Node_Id
is
1075 if Attribute_Name
(N
) = Name_Max
then
1079 Right_Opnd
=> Right
);
1084 Right_Opnd
=> Right
);
1088 -- Start of processing for Min_Max
1091 -- If both Left and Right are side effect free, then we can just
1092 -- use Duplicate_Expr to duplicate the references and return
1094 -- (if Left >=|<= Right then Left else Right)
1096 if Side_Effect_Free
(Left
) and then Side_Effect_Free
(Right
) then
1098 Make_If_Expression
(Loc
,
1099 Expressions
=> New_List
(
1100 Make_Compare
(Left
, Right
),
1101 Duplicate_Subexpr_No_Checks
(Left
),
1102 Duplicate_Subexpr_No_Checks
(Right
))));
1104 -- Otherwise we generate declarations to capture the values. We
1105 -- can't put these declarations inside the if expression, since
1106 -- we could end up with an N_Expression_With_Actions which has
1107 -- declarations in the actions, forbidden for Modify_Tree_For_C.
1109 -- The translation is
1111 -- T1 : styp; -- inserted high up in tree
1112 -- T2 : styp; -- inserted high up in tree
1115 -- T1 := styp!(Left);
1116 -- T2 := styp!(Right);
1118 -- (if T1 >=|<= T2 then typ!(T1) else typ!(T2))
1121 -- We insert the T1,T2 declarations with Insert_Declaration which
1122 -- inserts these declarations high up in the tree unconditionally.
1123 -- This is safe since no code is associated with the declarations.
1124 -- Here styp is a standard type whose Esize matches the size of
1125 -- our type. We do this because the actual type may be a result of
1126 -- some local declaration which would not be visible at the point
1127 -- where we insert the declarations of T1 and T2.
1131 T1
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1132 T2
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Left
);
1133 Styp
: constant Entity_Id
:= Matching_Standard_Type
(Typ
);
1136 Insert_Declaration
(N
,
1137 Make_Object_Declaration
(Loc
,
1138 Defining_Identifier
=> T1
,
1139 Object_Definition
=> New_Occurrence_Of
(Styp
, Loc
)));
1141 Insert_Declaration
(N
,
1142 Make_Object_Declaration
(Loc
,
1143 Defining_Identifier
=> T2
,
1144 Object_Definition
=> New_Occurrence_Of
(Styp
, Loc
)));
1147 Make_Expression_With_Actions
(Loc
,
1148 Actions
=> New_List
(
1149 Make_Assignment_Statement
(Loc
,
1150 Name
=> New_Occurrence_Of
(T1
, Loc
),
1151 Expression
=> Unchecked_Convert_To
(Styp
, Left
)),
1152 Make_Assignment_Statement
(Loc
,
1153 Name
=> New_Occurrence_Of
(T2
, Loc
),
1154 Expression
=> Unchecked_Convert_To
(Styp
, Right
))),
1157 Make_If_Expression
(Loc
,
1158 Expressions
=> New_List
(
1160 (New_Occurrence_Of
(T1
, Loc
),
1161 New_Occurrence_Of
(T2
, Loc
)),
1162 Unchecked_Convert_To
(Typ
,
1163 New_Occurrence_Of
(T1
, Loc
)),
1164 Unchecked_Convert_To
(Typ
,
1165 New_Occurrence_Of
(T2
, Loc
))))));
1169 Analyze_And_Resolve
(N
, Typ
);
1172 end Expand_Min_Max_Attribute
;
1174 ----------------------------------
1175 -- Expand_N_Attribute_Reference --
1176 ----------------------------------
1178 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1179 Loc
: constant Source_Ptr
:= Sloc
(N
);
1180 Typ
: constant Entity_Id
:= Etype
(N
);
1181 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1182 Pref
: constant Node_Id
:= Prefix
(N
);
1183 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1184 Exprs
: constant List_Id
:= Expressions
(N
);
1185 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1187 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1188 -- Rewrites a stream attribute for Read, Write or Output with the
1189 -- procedure call. Pname is the entity for the procedure to call.
1191 ------------------------------
1192 -- Rewrite_Stream_Proc_Call --
1193 ------------------------------
1195 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1196 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1197 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1198 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1199 Is_Written
: constant Boolean := (Ekind
(Formal
) /= E_In_Parameter
);
1202 -- The expansion depends on Item, the second actual, which is
1203 -- the object being streamed in or out.
1205 -- If the item is a component of a packed array type, and
1206 -- a conversion is needed on exit, we introduce a temporary to
1207 -- hold the value, because otherwise the packed reference will
1208 -- not be properly expanded.
1210 if Nkind
(Item
) = N_Indexed_Component
1211 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1212 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1216 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1222 Make_Object_Declaration
(Loc
,
1223 Defining_Identifier
=> Temp
,
1224 Object_Definition
=>
1225 New_Occurrence_Of
(Formal_Typ
, Loc
));
1226 Set_Etype
(Temp
, Formal_Typ
);
1229 Make_Assignment_Statement
(Loc
,
1230 Name
=> New_Copy_Tree
(Item
),
1232 Unchecked_Convert_To
1233 (Etype
(Item
), New_Occurrence_Of
(Temp
, Loc
)));
1235 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1239 Make_Procedure_Call_Statement
(Loc
,
1240 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1241 Parameter_Associations
=> Exprs
),
1244 Rewrite
(N
, Make_Null_Statement
(Loc
));
1249 -- For the class-wide dispatching cases, and for cases in which
1250 -- the base type of the second argument matches the base type of
1251 -- the corresponding formal parameter (that is to say the stream
1252 -- operation is not inherited), we are all set, and can use the
1253 -- argument unchanged.
1255 -- For all other cases we do an unchecked conversion of the second
1256 -- parameter to the type of the formal of the procedure we are
1257 -- calling. This deals with the private type cases, and with going
1258 -- to the root type as required in elementary type case.
1260 if not Is_Class_Wide_Type
(Entity
(Pref
))
1261 and then not Is_Class_Wide_Type
(Etype
(Item
))
1262 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1265 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1267 -- For untagged derived types set Assignment_OK, to prevent
1268 -- copies from being created when the unchecked conversion
1269 -- is expanded (which would happen in Remove_Side_Effects
1270 -- if Expand_N_Unchecked_Conversion were allowed to call
1271 -- Force_Evaluation). The copy could violate Ada semantics in
1272 -- cases such as an actual that is an out parameter. Note that
1273 -- this approach is also used in exp_ch7 for calls to controlled
1274 -- type operations to prevent problems with actuals wrapped in
1275 -- unchecked conversions.
1277 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1278 Set_Assignment_OK
(Item
);
1282 -- The stream operation to call may be a renaming created by an
1283 -- attribute definition clause, and may not be frozen yet. Ensure
1284 -- that it has the necessary extra formals.
1286 if not Is_Frozen
(Pname
) then
1287 Create_Extra_Formals
(Pname
);
1290 -- And now rewrite the call
1293 Make_Procedure_Call_Statement
(Loc
,
1294 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1295 Parameter_Associations
=> Exprs
));
1298 end Rewrite_Stream_Proc_Call
;
1300 -- Start of processing for Expand_N_Attribute_Reference
1303 -- Do required validity checking, if enabled. Do not apply check to
1304 -- output parameters of an Asm instruction, since the value of this
1305 -- is not set till after the attribute has been elaborated, and do
1306 -- not apply the check to the arguments of a 'Read or 'Input attribute
1307 -- reference since the scalar argument is an OUT scalar.
1309 if Validity_Checks_On
and then Validity_Check_Operands
1310 and then Id
/= Attribute_Asm_Output
1311 and then Id
/= Attribute_Read
1312 and then Id
/= Attribute_Input
1317 Expr
:= First
(Expressions
(N
));
1318 while Present
(Expr
) loop
1319 Ensure_Valid
(Expr
);
1325 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1326 -- place function, then a temporary return object needs to be created
1327 -- and access to it must be passed to the function. Currently we limit
1328 -- such functions to those with inherently limited result subtypes, but
1329 -- eventually we plan to expand the functions that are treated as
1330 -- build-in-place to include other composite result types.
1332 if Ada_Version
>= Ada_2005
1333 and then Is_Build_In_Place_Function_Call
(Pref
)
1335 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1338 -- If prefix is a protected type name, this is a reference to the
1339 -- current instance of the type. For a component definition, nothing
1340 -- to do (expansion will occur in the init proc). In other contexts,
1341 -- rewrite into reference to current instance.
1343 if Is_Protected_Self_Reference
(Pref
)
1345 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1346 N_Discriminant_Association
)
1347 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1348 N_Component_Definition
)
1350 -- No action needed for these attributes since the current instance
1351 -- will be rewritten to be the name of the _object parameter
1352 -- associated with the enclosing protected subprogram (see below).
1354 and then Id
/= Attribute_Access
1355 and then Id
/= Attribute_Unchecked_Access
1356 and then Id
/= Attribute_Unrestricted_Access
1358 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1362 -- Remaining processing depends on specific attribute
1364 -- Note: individual sections of the following case statement are
1365 -- allowed to assume there is no code after the case statement, and
1366 -- are legitimately allowed to execute return statements if they have
1367 -- nothing more to do.
1371 -- Attributes related to Ada 2012 iterators
1373 when Attribute_Constant_Indexing |
1374 Attribute_Default_Iterator |
1375 Attribute_Implicit_Dereference |
1376 Attribute_Iterable |
1377 Attribute_Iterator_Element |
1378 Attribute_Variable_Indexing
=>
1381 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1382 -- were already rejected by the parser. Thus they shouldn't appear here.
1384 when Internal_Attribute_Id
=>
1385 raise Program_Error
;
1391 when Attribute_Access |
1392 Attribute_Unchecked_Access |
1393 Attribute_Unrestricted_Access
=>
1395 Access_Cases
: declare
1396 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1397 Btyp_DDT
: Entity_Id
;
1399 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1400 -- If N denotes a compound name (selected component, indexed
1401 -- component, or slice), returns the name of the outermost such
1402 -- enclosing object. Otherwise returns N. If the object is a
1403 -- renaming, then the renamed object is returned.
1405 ----------------------
1406 -- Enclosing_Object --
1407 ----------------------
1409 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1414 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1415 N_Indexed_Component
,
1418 Obj_Name
:= Prefix
(Obj_Name
);
1421 return Get_Referenced_Object
(Obj_Name
);
1422 end Enclosing_Object
;
1424 -- Local declarations
1426 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1428 -- Start of processing for Access_Cases
1431 Btyp_DDT
:= Designated_Type
(Btyp
);
1433 -- Handle designated types that come from the limited view
1435 if Ekind
(Btyp_DDT
) = E_Incomplete_Type
1436 and then From_Limited_With
(Btyp_DDT
)
1437 and then Present
(Non_Limited_View
(Btyp_DDT
))
1439 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
1441 elsif Is_Class_Wide_Type
(Btyp_DDT
)
1442 and then Ekind
(Etype
(Btyp_DDT
)) = E_Incomplete_Type
1443 and then From_Limited_With
(Etype
(Btyp_DDT
))
1444 and then Present
(Non_Limited_View
(Etype
(Btyp_DDT
)))
1445 and then Present
(Class_Wide_Type
1446 (Non_Limited_View
(Etype
(Btyp_DDT
))))
1449 Class_Wide_Type
(Non_Limited_View
(Etype
(Btyp_DDT
)));
1452 -- In order to improve the text of error messages, the designated
1453 -- type of access-to-subprogram itypes is set by the semantics as
1454 -- the associated subprogram entity (see sem_attr). Now we replace
1455 -- such node with the proper E_Subprogram_Type itype.
1457 if Id
= Attribute_Unrestricted_Access
1458 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
1460 -- The following conditions ensure that this special management
1461 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1462 -- At this stage other cases in which the designated type is
1463 -- still a subprogram (instead of an E_Subprogram_Type) are
1464 -- wrong because the semantics must have overridden the type of
1465 -- the node with the type imposed by the context.
1467 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
1468 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
1470 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
1474 Subp
: constant Entity_Id
:=
1475 Directly_Designated_Type
(Typ
);
1477 Extra
: Entity_Id
:= Empty
;
1478 New_Formal
: Entity_Id
;
1479 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1480 Subp_Typ
: Entity_Id
;
1483 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
1484 Set_Etype
(Subp_Typ
, Etype
(Subp
));
1485 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1487 if Present
(Old_Formal
) then
1488 New_Formal
:= New_Copy
(Old_Formal
);
1489 Set_First_Entity
(Subp_Typ
, New_Formal
);
1492 Set_Scope
(New_Formal
, Subp_Typ
);
1493 Etyp
:= Etype
(New_Formal
);
1495 -- Handle itypes. There is no need to duplicate
1496 -- here the itypes associated with record types
1497 -- (i.e the implicit full view of private types).
1500 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
1502 Extra
:= New_Copy
(Etyp
);
1503 Set_Parent
(Extra
, New_Formal
);
1504 Set_Etype
(New_Formal
, Extra
);
1505 Set_Scope
(Extra
, Subp_Typ
);
1508 Extra
:= New_Formal
;
1509 Next_Formal
(Old_Formal
);
1510 exit when No
(Old_Formal
);
1512 Set_Next_Entity
(New_Formal
,
1513 New_Copy
(Old_Formal
));
1514 Next_Entity
(New_Formal
);
1517 Set_Next_Entity
(New_Formal
, Empty
);
1518 Set_Last_Entity
(Subp_Typ
, Extra
);
1521 -- Now that the explicit formals have been duplicated,
1522 -- any extra formals needed by the subprogram must be
1525 if Present
(Extra
) then
1526 Set_Extra_Formal
(Extra
, Empty
);
1529 Create_Extra_Formals
(Subp_Typ
);
1530 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
1535 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
1536 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
1538 -- If prefix is a type name, this is a reference to the current
1539 -- instance of the type, within its initialization procedure.
1541 elsif Is_Entity_Name
(Pref
)
1542 and then Is_Type
(Entity
(Pref
))
1549 -- If the current instance name denotes a task type, then
1550 -- the access attribute is rewritten to be the name of the
1551 -- "_task" parameter associated with the task type's task
1552 -- procedure. An unchecked conversion is applied to ensure
1553 -- a type match in cases of expander-generated calls (e.g.
1556 if Is_Task_Type
(Entity
(Pref
)) then
1558 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
1559 while Present
(Formal
) loop
1560 exit when Chars
(Formal
) = Name_uTask
;
1561 Next_Entity
(Formal
);
1564 pragma Assert
(Present
(Formal
));
1567 Unchecked_Convert_To
(Typ
,
1568 New_Occurrence_Of
(Formal
, Loc
)));
1571 elsif Is_Protected_Type
(Entity
(Pref
)) then
1573 -- No action needed for current instance located in a
1574 -- component definition (expansion will occur in the
1577 if Is_Protected_Type
(Current_Scope
) then
1580 -- If the current instance reference is located in a
1581 -- protected subprogram or entry then rewrite the access
1582 -- attribute to be the name of the "_object" parameter.
1583 -- An unchecked conversion is applied to ensure a type
1584 -- match in cases of expander-generated calls (e.g. init
1587 -- The code may be nested in a block, so find enclosing
1588 -- scope that is a protected operation.
1595 Subp
:= Current_Scope
;
1596 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
1597 Subp
:= Scope
(Subp
);
1602 (Protected_Body_Subprogram
(Subp
));
1604 -- For a protected subprogram the _Object parameter
1605 -- is the protected record, so we create an access
1606 -- to it. The _Object parameter of an entry is an
1609 if Ekind
(Subp
) = E_Entry
then
1611 Unchecked_Convert_To
(Typ
,
1612 New_Occurrence_Of
(Formal
, Loc
)));
1617 Unchecked_Convert_To
(Typ
,
1618 Make_Attribute_Reference
(Loc
,
1619 Attribute_Name
=> Name_Unrestricted_Access
,
1621 New_Occurrence_Of
(Formal
, Loc
))));
1622 Analyze_And_Resolve
(N
);
1627 -- The expression must appear in a default expression,
1628 -- (which in the initialization procedure is the right-hand
1629 -- side of an assignment), and not in a discriminant
1634 while Present
(Par
) loop
1635 exit when Nkind
(Par
) = N_Assignment_Statement
;
1637 if Nkind
(Par
) = N_Component_Declaration
then
1641 Par
:= Parent
(Par
);
1644 if Present
(Par
) then
1646 Make_Attribute_Reference
(Loc
,
1647 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1648 Attribute_Name
=> Attribute_Name
(N
)));
1650 Analyze_And_Resolve
(N
, Typ
);
1655 -- If the prefix of an Access attribute is a dereference of an
1656 -- access parameter (or a renaming of such a dereference, or a
1657 -- subcomponent of such a dereference) and the context is a
1658 -- general access type (including the type of an object or
1659 -- component with an access_definition, but not the anonymous
1660 -- type of an access parameter or access discriminant), then
1661 -- apply an accessibility check to the access parameter. We used
1662 -- to rewrite the access parameter as a type conversion, but that
1663 -- could only be done if the immediate prefix of the Access
1664 -- attribute was the dereference, and didn't handle cases where
1665 -- the attribute is applied to a subcomponent of the dereference,
1666 -- since there's generally no available, appropriate access type
1667 -- to convert to in that case. The attribute is passed as the
1668 -- point to insert the check, because the access parameter may
1669 -- come from a renaming, possibly in a different scope, and the
1670 -- check must be associated with the attribute itself.
1672 elsif Id
= Attribute_Access
1673 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
1674 and then Is_Entity_Name
(Prefix
(Enc_Object
))
1675 and then (Ekind
(Btyp
) = E_General_Access_Type
1676 or else Is_Local_Anonymous_Access
(Btyp
))
1677 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
1678 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
1679 = E_Anonymous_Access_Type
1680 and then Present
(Extra_Accessibility
1681 (Entity
(Prefix
(Enc_Object
))))
1683 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
1685 -- Ada 2005 (AI-251): If the designated type is an interface we
1686 -- add an implicit conversion to force the displacement of the
1687 -- pointer to reference the secondary dispatch table.
1689 elsif Is_Interface
(Btyp_DDT
)
1690 and then (Comes_From_Source
(N
)
1691 or else Comes_From_Source
(Ref_Object
)
1692 or else (Nkind
(Ref_Object
) in N_Has_Chars
1693 and then Chars
(Ref_Object
) = Name_uInit
))
1695 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
1697 -- No implicit conversion required if types match, or if
1698 -- the prefix is the class_wide_type of the interface. In
1699 -- either case passing an object of the interface type has
1700 -- already set the pointer correctly.
1702 if Btyp_DDT
= Etype
(Ref_Object
)
1703 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
1705 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
1710 Rewrite
(Prefix
(N
),
1711 Convert_To
(Btyp_DDT
,
1712 New_Copy_Tree
(Prefix
(N
))));
1714 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
1717 -- When the object is an explicit dereference, convert the
1718 -- dereference's prefix.
1722 Obj_DDT
: constant Entity_Id
:=
1724 (Directly_Designated_Type
1725 (Etype
(Prefix
(Ref_Object
))));
1727 -- No implicit conversion required if designated types
1728 -- match, or if we have an unrestricted access.
1730 if Obj_DDT
/= Btyp_DDT
1731 and then Id
/= Attribute_Unrestricted_Access
1732 and then not (Is_Class_Wide_Type
(Obj_DDT
)
1733 and then Etype
(Obj_DDT
) = Btyp_DDT
)
1737 New_Copy_Tree
(Prefix
(Ref_Object
))));
1738 Analyze_And_Resolve
(N
, Typ
);
1749 -- Transforms 'Adjacent into a call to the floating-point attribute
1750 -- function Adjacent in Fat_xxx (where xxx is the root type)
1752 when Attribute_Adjacent
=>
1753 Expand_Fpt_Attribute_RR
(N
);
1759 when Attribute_Address
=> Address
: declare
1760 Task_Proc
: Entity_Id
;
1763 -- If the prefix is a task or a task type, the useful address is that
1764 -- of the procedure for the task body, i.e. the actual program unit.
1765 -- We replace the original entity with that of the procedure.
1767 if Is_Entity_Name
(Pref
)
1768 and then Is_Task_Type
(Entity
(Pref
))
1770 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
1772 while Present
(Task_Proc
) loop
1773 exit when Ekind
(Task_Proc
) = E_Procedure
1774 and then Etype
(First_Formal
(Task_Proc
)) =
1775 Corresponding_Record_Type
(Ptyp
);
1776 Next_Entity
(Task_Proc
);
1779 if Present
(Task_Proc
) then
1780 Set_Entity
(Pref
, Task_Proc
);
1781 Set_Etype
(Pref
, Etype
(Task_Proc
));
1784 -- Similarly, the address of a protected operation is the address
1785 -- of the corresponding protected body, regardless of the protected
1786 -- object from which it is selected.
1788 elsif Nkind
(Pref
) = N_Selected_Component
1789 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
1790 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
1794 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
1796 elsif Nkind
(Pref
) = N_Explicit_Dereference
1797 and then Ekind
(Ptyp
) = E_Subprogram_Type
1798 and then Convention
(Ptyp
) = Convention_Protected
1800 -- The prefix is be a dereference of an access_to_protected_
1801 -- subprogram. The desired address is the second component of
1802 -- the record that represents the access.
1805 Addr
: constant Entity_Id
:= Etype
(N
);
1806 Ptr
: constant Node_Id
:= Prefix
(Pref
);
1807 T
: constant Entity_Id
:=
1808 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1812 Unchecked_Convert_To
(Addr
,
1813 Make_Selected_Component
(Loc
,
1814 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1815 Selector_Name
=> New_Occurrence_Of
(
1816 Next_Entity
(First_Entity
(T
)), Loc
))));
1818 Analyze_And_Resolve
(N
, Addr
);
1821 -- Ada 2005 (AI-251): Class-wide interface objects are always
1822 -- "displaced" to reference the tag associated with the interface
1823 -- type. In order to obtain the real address of such objects we
1824 -- generate a call to a run-time subprogram that returns the base
1825 -- address of the object.
1827 -- This processing is not needed in the VM case, where dispatching
1828 -- issues are taken care of by the virtual machine.
1830 elsif Is_Class_Wide_Type
(Ptyp
)
1831 and then Is_Interface
(Ptyp
)
1832 and then Tagged_Type_Expansion
1833 and then not (Nkind
(Pref
) in N_Has_Entity
1834 and then Is_Subprogram
(Entity
(Pref
)))
1837 Make_Function_Call
(Loc
,
1838 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
1839 Parameter_Associations
=> New_List
(
1840 Relocate_Node
(N
))));
1845 -- Deal with packed array reference, other cases are handled by
1848 if Involves_Packed_Array_Reference
(Pref
) then
1849 Expand_Packed_Address_Reference
(N
);
1857 when Attribute_Alignment
=> Alignment
: declare
1861 -- For class-wide types, X'Class'Alignment is transformed into a
1862 -- direct reference to the Alignment of the class type, so that the
1863 -- back end does not have to deal with the X'Class'Alignment
1866 if Is_Entity_Name
(Pref
)
1867 and then Is_Class_Wide_Type
(Entity
(Pref
))
1869 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
1872 -- For x'Alignment applied to an object of a class wide type,
1873 -- transform X'Alignment into a call to the predefined primitive
1874 -- operation _Alignment applied to X.
1876 elsif Is_Class_Wide_Type
(Ptyp
) then
1878 Make_Attribute_Reference
(Loc
,
1880 Attribute_Name
=> Name_Tag
);
1882 if VM_Target
= No_VM
then
1883 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
1886 Make_Function_Call
(Loc
,
1887 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Alignment
), Loc
),
1888 Parameter_Associations
=> New_List
(New_Node
));
1891 -- Case where the context is a specific integer type with which
1892 -- the original attribute was compatible. The function has a
1893 -- specific type as well, so to preserve the compatibility we
1894 -- must convert explicitly.
1896 if Typ
/= Standard_Integer
then
1897 New_Node
:= Convert_To
(Typ
, New_Node
);
1900 Rewrite
(N
, New_Node
);
1901 Analyze_And_Resolve
(N
, Typ
);
1904 -- For all other cases, we just have to deal with the case of
1905 -- the fact that the result can be universal.
1908 Apply_Universal_Integer_Attribute_Checks
(N
);
1916 when Attribute_AST_Entry
=> AST_Entry
: declare
1921 Entry_Ref
: Node_Id
;
1922 -- The reference to the entry or entry family
1925 -- The index expression for an entry family reference, or
1926 -- the Empty if Entry_Ref references a simple entry.
1929 if Nkind
(Pref
) = N_Indexed_Component
then
1930 Entry_Ref
:= Prefix
(Pref
);
1931 Index
:= First
(Expressions
(Pref
));
1937 -- Get expression for Task_Id and the entry entity
1939 if Nkind
(Entry_Ref
) = N_Selected_Component
then
1941 Make_Attribute_Reference
(Loc
,
1942 Attribute_Name
=> Name_Identity
,
1943 Prefix
=> Prefix
(Entry_Ref
));
1945 Ttyp
:= Etype
(Prefix
(Entry_Ref
));
1946 Eent
:= Entity
(Selector_Name
(Entry_Ref
));
1950 Make_Function_Call
(Loc
,
1951 Name
=> New_Occurrence_Of
(RTE
(RE_Current_Task
), Loc
));
1953 Eent
:= Entity
(Entry_Ref
);
1955 -- We have to find the enclosing task to get the task type
1956 -- There must be one, since we already validated this earlier
1958 Ttyp
:= Current_Scope
;
1959 while not Is_Task_Type
(Ttyp
) loop
1960 Ttyp
:= Scope
(Ttyp
);
1964 -- Now rewrite the attribute with a call to Create_AST_Handler
1967 Make_Function_Call
(Loc
,
1968 Name
=> New_Occurrence_Of
(RTE
(RE_Create_AST_Handler
), Loc
),
1969 Parameter_Associations
=> New_List
(
1971 Entry_Index_Expression
(Loc
, Eent
, Index
, Ttyp
))));
1973 Analyze_And_Resolve
(N
, RTE
(RE_AST_Handler
));
1980 -- We compute this if a packed array reference was present, otherwise we
1981 -- leave the computation up to the back end.
1983 when Attribute_Bit
=>
1984 if Involves_Packed_Array_Reference
(Pref
) then
1985 Expand_Packed_Bit_Reference
(N
);
1987 Apply_Universal_Integer_Attribute_Checks
(N
);
1994 -- We compute this if a component clause was present, otherwise we leave
1995 -- the computation up to the back end, since we don't know what layout
1998 -- Note that the attribute can apply to a naked record component
1999 -- in generated code (i.e. the prefix is an identifier that
2000 -- references the component or discriminant entity).
2002 when Attribute_Bit_Position
=> Bit_Position
: declare
2006 if Nkind
(Pref
) = N_Identifier
then
2007 CE
:= Entity
(Pref
);
2009 CE
:= Entity
(Selector_Name
(Pref
));
2012 if Known_Static_Component_Bit_Offset
(CE
) then
2014 Make_Integer_Literal
(Loc
,
2015 Intval
=> Component_Bit_Offset
(CE
)));
2016 Analyze_And_Resolve
(N
, Typ
);
2019 Apply_Universal_Integer_Attribute_Checks
(N
);
2027 -- A reference to P'Body_Version or P'Version is expanded to
2030 -- pragma Import (C, Vnn, "uuuuT");
2032 -- Get_Version_String (Vnn)
2034 -- where uuuu is the unit name (dots replaced by double underscore)
2035 -- and T is B for the cases of Body_Version, or Version applied to a
2036 -- subprogram acting as its own spec, and S for Version applied to a
2037 -- subprogram spec or package. This sequence of code references the
2038 -- unsigned constant created in the main program by the binder.
2040 -- A special exception occurs for Standard, where the string returned
2041 -- is a copy of the library string in gnatvsn.ads.
2043 when Attribute_Body_Version | Attribute_Version
=> Version
: declare
2044 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2049 -- If not library unit, get to containing library unit
2051 Pent
:= Entity
(Pref
);
2052 while Pent
/= Standard_Standard
2053 and then Scope
(Pent
) /= Standard_Standard
2054 and then not Is_Child_Unit
(Pent
)
2056 Pent
:= Scope
(Pent
);
2059 -- Special case Standard and Standard.ASCII
2061 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2063 Make_String_Literal
(Loc
,
2064 Strval
=> Verbose_Library_Version
));
2069 -- Build required string constant
2071 Get_Name_String
(Get_Unit_Name
(Pent
));
2074 for J
in 1 .. Name_Len
- 2 loop
2075 if Name_Buffer
(J
) = '.' then
2076 Store_String_Chars
("__");
2078 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2082 -- Case of subprogram acting as its own spec, always use body
2084 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2085 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2087 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2089 Store_String_Chars
("B");
2091 -- Case of no body present, always use spec
2093 elsif not Unit_Requires_Body
(Pent
) then
2094 Store_String_Chars
("S");
2096 -- Otherwise use B for Body_Version, S for spec
2098 elsif Id
= Attribute_Body_Version
then
2099 Store_String_Chars
("B");
2101 Store_String_Chars
("S");
2105 Lib
.Version_Referenced
(S
);
2107 -- Insert the object declaration
2109 Insert_Actions
(N
, New_List
(
2110 Make_Object_Declaration
(Loc
,
2111 Defining_Identifier
=> E
,
2112 Object_Definition
=>
2113 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2115 -- Set entity as imported with correct external name
2117 Set_Is_Imported
(E
);
2118 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2120 -- Set entity as internal to ensure proper Sprint output of its
2121 -- implicit importation.
2123 Set_Is_Internal
(E
);
2125 -- And now rewrite original reference
2128 Make_Function_Call
(Loc
,
2129 Name
=> New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2130 Parameter_Associations
=> New_List
(
2131 New_Occurrence_Of
(E
, Loc
))));
2134 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2141 -- Transforms 'Ceiling into a call to the floating-point attribute
2142 -- function Ceiling in Fat_xxx (where xxx is the root type)
2144 when Attribute_Ceiling
=>
2145 Expand_Fpt_Attribute_R
(N
);
2151 -- Transforms 'Callable attribute into a call to the Callable function
2153 when Attribute_Callable
=> Callable
:
2155 -- We have an object of a task interface class-wide type as a prefix
2156 -- to Callable. Generate:
2157 -- callable (Task_Id (Pref._disp_get_task_id));
2159 if Ada_Version
>= Ada_2005
2160 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2161 and then Is_Interface
(Ptyp
)
2162 and then Is_Task_Interface
(Ptyp
)
2165 Make_Function_Call
(Loc
,
2167 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2168 Parameter_Associations
=> New_List
(
2169 Make_Unchecked_Type_Conversion
(Loc
,
2171 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
2173 Make_Selected_Component
(Loc
,
2175 New_Copy_Tree
(Pref
),
2177 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
2181 Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2184 Analyze_And_Resolve
(N
, Standard_Boolean
);
2191 -- Transforms 'Caller attribute into a call to either the
2192 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2194 when Attribute_Caller
=> Caller
: declare
2195 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2196 Ent
: constant Entity_Id
:= Entity
(Pref
);
2197 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2198 Nest_Depth
: Integer := 0;
2205 if Is_Protected_Type
(Conctype
) then
2206 case Corresponding_Runtime_Package
(Conctype
) is
2207 when System_Tasking_Protected_Objects_Entries
=>
2210 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2212 when System_Tasking_Protected_Objects_Single_Entry
=>
2215 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2218 raise Program_Error
;
2222 Unchecked_Convert_To
(Id_Kind
,
2223 Make_Function_Call
(Loc
,
2225 Parameter_Associations
=> New_List
(
2227 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2232 -- Determine the nesting depth of the E'Caller attribute, that
2233 -- is, how many accept statements are nested within the accept
2234 -- statement for E at the point of E'Caller. The runtime uses
2235 -- this depth to find the specified entry call.
2237 for J
in reverse 0 .. Scope_Stack
.Last
loop
2238 S
:= Scope_Stack
.Table
(J
).Entity
;
2240 -- We should not reach the scope of the entry, as it should
2241 -- already have been checked in Sem_Attr that this attribute
2242 -- reference is within a matching accept statement.
2244 pragma Assert
(S
/= Conctype
);
2249 elsif Is_Entry
(S
) then
2250 Nest_Depth
:= Nest_Depth
+ 1;
2255 Unchecked_Convert_To
(Id_Kind
,
2256 Make_Function_Call
(Loc
,
2258 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
2259 Parameter_Associations
=> New_List
(
2260 Make_Integer_Literal
(Loc
,
2261 Intval
=> Int
(Nest_Depth
))))));
2264 Analyze_And_Resolve
(N
, Id_Kind
);
2271 -- Transforms 'Compose into a call to the floating-point attribute
2272 -- function Compose in Fat_xxx (where xxx is the root type)
2274 -- Note: we strictly should have special code here to deal with the
2275 -- case of absurdly negative arguments (less than Integer'First)
2276 -- which will return a (signed) zero value, but it hardly seems
2277 -- worth the effort. Absurdly large positive arguments will raise
2278 -- constraint error which is fine.
2280 when Attribute_Compose
=>
2281 Expand_Fpt_Attribute_RI
(N
);
2287 when Attribute_Constrained
=> Constrained
: declare
2288 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2290 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2291 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2292 -- view of an aliased object whose subtype is constrained.
2294 ---------------------------------
2295 -- Is_Constrained_Aliased_View --
2296 ---------------------------------
2298 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2302 if Is_Entity_Name
(Obj
) then
2305 if Present
(Renamed_Object
(E
)) then
2306 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2308 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2312 return Is_Aliased_View
(Obj
)
2314 (Is_Constrained
(Etype
(Obj
))
2316 (Nkind
(Obj
) = N_Explicit_Dereference
2318 not Object_Type_Has_Constrained_Partial_View
2319 (Typ
=> Base_Type
(Etype
(Obj
)),
2320 Scop
=> Current_Scope
)));
2322 end Is_Constrained_Aliased_View
;
2324 -- Start of processing for Constrained
2327 -- Reference to a parameter where the value is passed as an extra
2328 -- actual, corresponding to the extra formal referenced by the
2329 -- Extra_Constrained field of the corresponding formal. If this
2330 -- is an entry in-parameter, it is replaced by a constant renaming
2331 -- for which Extra_Constrained is never created.
2333 if Present
(Formal_Ent
)
2334 and then Ekind
(Formal_Ent
) /= E_Constant
2335 and then Present
(Extra_Constrained
(Formal_Ent
))
2339 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2341 -- For variables with a Extra_Constrained field, we use the
2342 -- corresponding entity.
2344 elsif Nkind
(Pref
) = N_Identifier
2345 and then Ekind
(Entity
(Pref
)) = E_Variable
2346 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2350 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2352 -- For all other entity names, we can tell at compile time
2354 elsif Is_Entity_Name
(Pref
) then
2356 Ent
: constant Entity_Id
:= Entity
(Pref
);
2360 -- (RM J.4) obsolescent cases
2362 if Is_Type
(Ent
) then
2366 if Is_Private_Type
(Ent
) then
2367 Res
:= not Has_Discriminants
(Ent
)
2368 or else Is_Constrained
(Ent
);
2370 -- It not a private type, must be a generic actual type
2371 -- that corresponded to a private type. We know that this
2372 -- correspondence holds, since otherwise the reference
2373 -- within the generic template would have been illegal.
2376 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2377 Res
:= Is_Constrained
(Ent
);
2383 -- If the prefix is not a variable or is aliased, then
2384 -- definitely true; if it's a formal parameter without an
2385 -- associated extra formal, then treat it as constrained.
2387 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2388 -- constrained in order to set the attribute to True.
2390 elsif not Is_Variable
(Pref
)
2391 or else Present
(Formal_Ent
)
2392 or else (Ada_Version
< Ada_2005
2393 and then Is_Aliased_View
(Pref
))
2394 or else (Ada_Version
>= Ada_2005
2395 and then Is_Constrained_Aliased_View
(Pref
))
2399 -- Variable case, look at type to see if it is constrained.
2400 -- Note that the one case where this is not accurate (the
2401 -- procedure formal case), has been handled above.
2403 -- We use the Underlying_Type here (and below) in case the
2404 -- type is private without discriminants, but the full type
2405 -- has discriminants. This case is illegal, but we generate it
2406 -- internally for passing to the Extra_Constrained parameter.
2409 -- In Ada 2012, test for case of a limited tagged type, in
2410 -- which case the attribute is always required to return
2411 -- True. The underlying type is tested, to make sure we also
2412 -- return True for cases where there is an unconstrained
2413 -- object with an untagged limited partial view which has
2414 -- defaulted discriminants (such objects always produce a
2415 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2417 Res
:= Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2419 (Ada_Version
>= Ada_2012
2420 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2421 and then Is_Limited_Type
(Ptyp
));
2424 Rewrite
(N
, New_Occurrence_Of
(Boolean_Literals
(Res
), Loc
));
2427 -- Prefix is not an entity name. These are also cases where we can
2428 -- always tell at compile time by looking at the form and type of the
2429 -- prefix. If an explicit dereference of an object with constrained
2430 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2431 -- underlying type is a limited tagged type, then Constrained is
2432 -- required to always return True (Ada 2012: AI05-0214).
2438 not Is_Variable
(Pref
)
2440 (Nkind
(Pref
) = N_Explicit_Dereference
2442 not Object_Type_Has_Constrained_Partial_View
2443 (Typ
=> Base_Type
(Ptyp
),
2444 Scop
=> Current_Scope
))
2445 or else Is_Constrained
(Underlying_Type
(Ptyp
))
2446 or else (Ada_Version
>= Ada_2012
2447 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2448 and then Is_Limited_Type
(Ptyp
))),
2452 Analyze_And_Resolve
(N
, Standard_Boolean
);
2459 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2460 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2462 when Attribute_Copy_Sign
=>
2463 Expand_Fpt_Attribute_RR
(N
);
2469 -- Transforms 'Count attribute into a call to the Count function
2471 when Attribute_Count
=> Count
: declare
2473 Conctyp
: Entity_Id
;
2475 Entry_Id
: Entity_Id
;
2480 -- If the prefix is a member of an entry family, retrieve both
2481 -- entry name and index. For a simple entry there is no index.
2483 if Nkind
(Pref
) = N_Indexed_Component
then
2484 Entnam
:= Prefix
(Pref
);
2485 Index
:= First
(Expressions
(Pref
));
2491 Entry_Id
:= Entity
(Entnam
);
2493 -- Find the concurrent type in which this attribute is referenced
2494 -- (there had better be one).
2496 Conctyp
:= Current_Scope
;
2497 while not Is_Concurrent_Type
(Conctyp
) loop
2498 Conctyp
:= Scope
(Conctyp
);
2503 if Is_Protected_Type
(Conctyp
) then
2504 case Corresponding_Runtime_Package
(Conctyp
) is
2505 when System_Tasking_Protected_Objects_Entries
=>
2506 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
2509 Make_Function_Call
(Loc
,
2511 Parameter_Associations
=> New_List
(
2513 (Find_Protection_Object
(Current_Scope
), Loc
),
2514 Entry_Index_Expression
2515 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2517 when System_Tasking_Protected_Objects_Single_Entry
=>
2519 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
2522 Make_Function_Call
(Loc
,
2524 Parameter_Associations
=> New_List
(
2526 (Find_Protection_Object
(Current_Scope
), Loc
)));
2529 raise Program_Error
;
2536 Make_Function_Call
(Loc
,
2537 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
2538 Parameter_Associations
=> New_List
(
2539 Entry_Index_Expression
(Loc
,
2540 Entry_Id
, Index
, Scope
(Entry_Id
))));
2543 -- The call returns type Natural but the context is universal integer
2544 -- so any integer type is allowed. The attribute was already resolved
2545 -- so its Etype is the required result type. If the base type of the
2546 -- context type is other than Standard.Integer we put in a conversion
2547 -- to the required type. This can be a normal typed conversion since
2548 -- both input and output types of the conversion are integer types
2550 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2551 Rewrite
(N
, Convert_To
(Typ
, Call
));
2556 Analyze_And_Resolve
(N
, Typ
);
2559 ---------------------
2560 -- Descriptor_Size --
2561 ---------------------
2563 when Attribute_Descriptor_Size
=>
2565 -- Attribute Descriptor_Size is handled by the back end when applied
2566 -- to an unconstrained array type.
2568 if Is_Array_Type
(Ptyp
)
2569 and then not Is_Constrained
(Ptyp
)
2571 Apply_Universal_Integer_Attribute_Checks
(N
);
2573 -- For any other type, the descriptor size is 0 because there is no
2574 -- actual descriptor, but the result is not formally static.
2577 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2579 Set_Is_Static_Expression
(N
, False);
2586 -- This processing is shared by Elab_Spec
2588 -- What we do is to insert the following declarations
2591 -- pragma Import (C, enn, "name___elabb/s");
2593 -- and then the Elab_Body/Spec attribute is replaced by a reference
2594 -- to this defining identifier.
2596 when Attribute_Elab_Body |
2597 Attribute_Elab_Spec
=>
2599 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2600 -- back-end knows how to handle these attributes directly.
2602 if CodePeer_Mode
then
2607 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
2611 procedure Make_Elab_String
(Nod
: Node_Id
);
2612 -- Given Nod, an identifier, or a selected component, put the
2613 -- image into the current string literal, with double underline
2614 -- between components.
2616 ----------------------
2617 -- Make_Elab_String --
2618 ----------------------
2620 procedure Make_Elab_String
(Nod
: Node_Id
) is
2622 if Nkind
(Nod
) = N_Selected_Component
then
2623 Make_Elab_String
(Prefix
(Nod
));
2627 Store_String_Char
('$');
2629 Store_String_Char
('.');
2631 Store_String_Char
('_');
2632 Store_String_Char
('_');
2635 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
2638 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
2639 Get_Name_String
(Chars
(Nod
));
2642 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2643 end Make_Elab_String
;
2645 -- Start of processing for Elab_Body/Elab_Spec
2648 -- First we need to prepare the string literal for the name of
2649 -- the elaboration routine to be referenced.
2652 Make_Elab_String
(Pref
);
2654 if VM_Target
= No_VM
then
2655 Store_String_Chars
("___elab");
2656 Lang
:= Make_Identifier
(Loc
, Name_C
);
2658 Store_String_Chars
("._elab");
2659 Lang
:= Make_Identifier
(Loc
, Name_Ada
);
2662 if Id
= Attribute_Elab_Body
then
2663 Store_String_Char
('b');
2665 Store_String_Char
('s');
2670 Insert_Actions
(N
, New_List
(
2671 Make_Subprogram_Declaration
(Loc
,
2673 Make_Procedure_Specification
(Loc
,
2674 Defining_Unit_Name
=> Ent
)),
2677 Chars
=> Name_Import
,
2678 Pragma_Argument_Associations
=> New_List
(
2679 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
2681 Make_Pragma_Argument_Association
(Loc
,
2682 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
2684 Make_Pragma_Argument_Association
(Loc
,
2685 Expression
=> Make_String_Literal
(Loc
, Str
))))));
2687 Set_Entity
(N
, Ent
);
2688 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
2691 --------------------
2692 -- Elab_Subp_Body --
2693 --------------------
2695 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2696 -- this attribute directly, and if we are not in CodePeer mode it is
2697 -- entirely ignored ???
2699 when Attribute_Elab_Subp_Body
=>
2706 -- Elaborated is always True for preelaborated units, predefined units,
2707 -- pure units and units which have Elaborate_Body pragmas. These units
2708 -- have no elaboration entity.
2710 -- Note: The Elaborated attribute is never passed to the back end
2712 when Attribute_Elaborated
=> Elaborated
: declare
2713 Ent
: constant Entity_Id
:= Entity
(Pref
);
2716 if Present
(Elaboration_Entity
(Ent
)) then
2720 New_Occurrence_Of
(Elaboration_Entity
(Ent
), Loc
),
2722 Make_Integer_Literal
(Loc
, Uint_0
)));
2723 Analyze_And_Resolve
(N
, Typ
);
2725 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2733 when Attribute_Enum_Rep
=> Enum_Rep
:
2735 -- X'Enum_Rep (Y) expands to
2739 -- This is simply a direct conversion from the enumeration type to
2740 -- the target integer type, which is treated by the back end as a
2741 -- normal integer conversion, treating the enumeration type as an
2742 -- integer, which is exactly what we want. We set Conversion_OK to
2743 -- make sure that the analyzer does not complain about what otherwise
2744 -- might be an illegal conversion.
2746 if Is_Non_Empty_List
(Exprs
) then
2748 OK_Convert_To
(Typ
, Relocate_Node
(First
(Exprs
))));
2750 -- X'Enum_Rep where X is an enumeration literal is replaced by
2751 -- the literal value.
2753 elsif Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
then
2755 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Pref
))));
2757 -- If this is a renaming of a literal, recover the representation
2760 elsif Ekind
(Entity
(Pref
)) = E_Constant
2761 and then Present
(Renamed_Object
(Entity
(Pref
)))
2763 Ekind
(Entity
(Renamed_Object
(Entity
(Pref
))))
2764 = E_Enumeration_Literal
2767 Make_Integer_Literal
(Loc
,
2768 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Pref
))))));
2770 -- X'Enum_Rep where X is an object does a direct unchecked conversion
2771 -- of the object value, as described for the type case above.
2775 OK_Convert_To
(Typ
, Relocate_Node
(Pref
)));
2779 Analyze_And_Resolve
(N
, Typ
);
2786 when Attribute_Enum_Val
=> Enum_Val
: declare
2788 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
2791 -- X'Enum_Val (Y) expands to
2793 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
2796 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
2799 Make_Raise_Constraint_Error
(Loc
,
2803 Make_Function_Call
(Loc
,
2805 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
2806 Parameter_Associations
=> New_List
(
2807 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
2808 New_Occurrence_Of
(Standard_False
, Loc
))),
2810 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
2811 Reason
=> CE_Range_Check_Failed
));
2814 Analyze_And_Resolve
(N
, Ptyp
);
2821 -- Transforms 'Exponent into a call to the floating-point attribute
2822 -- function Exponent in Fat_xxx (where xxx is the root type)
2824 when Attribute_Exponent
=>
2825 Expand_Fpt_Attribute_R
(N
);
2831 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2833 when Attribute_External_Tag
=> External_Tag
:
2836 Make_Function_Call
(Loc
,
2837 Name
=> New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
2838 Parameter_Associations
=> New_List
(
2839 Make_Attribute_Reference
(Loc
,
2840 Attribute_Name
=> Name_Tag
,
2841 Prefix
=> Prefix
(N
)))));
2843 Analyze_And_Resolve
(N
, Standard_String
);
2850 when Attribute_First
=>
2852 -- If the prefix type is a constrained packed array type which
2853 -- already has a Packed_Array_Type representation defined, then
2854 -- replace this attribute with a direct reference to 'First of the
2855 -- appropriate index subtype (since otherwise the back end will try
2856 -- to give us the value of 'First for this implementation type).
2858 if Is_Constrained_Packed_Array
(Ptyp
) then
2860 Make_Attribute_Reference
(Loc
,
2861 Attribute_Name
=> Name_First
,
2862 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
2863 Analyze_And_Resolve
(N
, Typ
);
2865 elsif Is_Access_Type
(Ptyp
) then
2866 Apply_Access_Check
(N
);
2873 -- Compute this if component clause was present, otherwise we leave the
2874 -- computation to be completed in the back-end, since we don't know what
2875 -- layout will be chosen.
2877 when Attribute_First_Bit
=> First_Bit_Attr
: declare
2878 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
2881 -- In Ada 2005 (or later) if we have the non-default bit order, then
2882 -- we return the original value as given in the component clause
2883 -- (RM 2005 13.5.2(3/2)).
2885 if Present
(Component_Clause
(CE
))
2886 and then Ada_Version
>= Ada_2005
2887 and then Reverse_Bit_Order
(Scope
(CE
))
2890 Make_Integer_Literal
(Loc
,
2891 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
2892 Analyze_And_Resolve
(N
, Typ
);
2894 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
2895 -- rewrite with normalized value if we know it statically.
2897 elsif Known_Static_Component_Bit_Offset
(CE
) then
2899 Make_Integer_Literal
(Loc
,
2900 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
2901 Analyze_And_Resolve
(N
, Typ
);
2903 -- Otherwise left to back end, just do universal integer checks
2906 Apply_Universal_Integer_Attribute_Checks
(N
);
2916 -- fixtype'Fixed_Value (integer-value)
2920 -- fixtype(integer-value)
2922 -- We do all the required analysis of the conversion here, because we do
2923 -- not want this to go through the fixed-point conversion circuits. Note
2924 -- that the back end always treats fixed-point as equivalent to the
2925 -- corresponding integer type anyway.
2927 when Attribute_Fixed_Value
=> Fixed_Value
:
2930 Make_Type_Conversion
(Loc
,
2931 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
2932 Expression
=> Relocate_Node
(First
(Exprs
))));
2933 Set_Etype
(N
, Entity
(Pref
));
2936 -- Note: it might appear that a properly analyzed unchecked conversion
2937 -- would be just fine here, but that's not the case, since the full
2938 -- range checks performed by the following call are critical.
2940 Apply_Type_Conversion_Checks
(N
);
2947 -- Transforms 'Floor into a call to the floating-point attribute
2948 -- function Floor in Fat_xxx (where xxx is the root type)
2950 when Attribute_Floor
=>
2951 Expand_Fpt_Attribute_R
(N
);
2957 -- For the fixed-point type Typ:
2963 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2964 -- Universal_Real (Type'Last))
2966 -- Note that we know that the type is a non-static subtype, or Fore
2967 -- would have itself been computed dynamically in Eval_Attribute.
2969 when Attribute_Fore
=> Fore
: begin
2972 Make_Function_Call
(Loc
,
2973 Name
=> New_Occurrence_Of
(RTE
(RE_Fore
), Loc
),
2975 Parameter_Associations
=> New_List
(
2976 Convert_To
(Universal_Real
,
2977 Make_Attribute_Reference
(Loc
,
2978 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2979 Attribute_Name
=> Name_First
)),
2981 Convert_To
(Universal_Real
,
2982 Make_Attribute_Reference
(Loc
,
2983 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2984 Attribute_Name
=> Name_Last
))))));
2986 Analyze_And_Resolve
(N
, Typ
);
2993 -- Transforms 'Fraction into a call to the floating-point attribute
2994 -- function Fraction in Fat_xxx (where xxx is the root type)
2996 when Attribute_Fraction
=>
2997 Expand_Fpt_Attribute_R
(N
);
3003 when Attribute_From_Any
=> From_Any
: declare
3004 P_Type
: constant Entity_Id
:= Etype
(Pref
);
3005 Decls
: constant List_Id
:= New_List
;
3008 Build_From_Any_Call
(P_Type
,
3009 Relocate_Node
(First
(Exprs
)),
3011 Insert_Actions
(N
, Decls
);
3012 Analyze_And_Resolve
(N
, P_Type
);
3019 -- For an exception returns a reference to the exception data:
3020 -- Exception_Id!(Prefix'Reference)
3022 -- For a task it returns a reference to the _task_id component of
3023 -- corresponding record:
3025 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3027 -- in Ada.Task_Identification
3029 when Attribute_Identity
=> Identity
: declare
3030 Id_Kind
: Entity_Id
;
3033 if Ptyp
= Standard_Exception_Type
then
3034 Id_Kind
:= RTE
(RE_Exception_Id
);
3036 if Present
(Renamed_Object
(Entity
(Pref
))) then
3037 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
3041 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
3043 Id_Kind
:= RTE
(RO_AT_Task_Id
);
3045 -- If the prefix is a task interface, the Task_Id is obtained
3046 -- dynamically through a dispatching call, as for other task
3047 -- attributes applied to interfaces.
3049 if Ada_Version
>= Ada_2005
3050 and then Ekind
(Ptyp
) = E_Class_Wide_Type
3051 and then Is_Interface
(Ptyp
)
3052 and then Is_Task_Interface
(Ptyp
)
3055 Unchecked_Convert_To
(Id_Kind
,
3056 Make_Selected_Component
(Loc
,
3058 New_Copy_Tree
(Pref
),
3060 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))));
3064 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
3068 Analyze_And_Resolve
(N
, Id_Kind
);
3075 -- Image attribute is handled in separate unit Exp_Imgv
3077 when Attribute_Image
=>
3078 Exp_Imgv
.Expand_Image_Attribute
(N
);
3084 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3086 when Attribute_Img
=> Img
:
3089 Make_Attribute_Reference
(Loc
,
3090 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3091 Attribute_Name
=> Name_Image
,
3092 Expressions
=> New_List
(Relocate_Node
(Pref
))));
3094 Analyze_And_Resolve
(N
, Standard_String
);
3101 when Attribute_Input
=> Input
: declare
3102 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3103 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3104 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3105 Strm
: constant Node_Id
:= First
(Exprs
);
3113 Cntrl
: Node_Id
:= Empty
;
3114 -- Value for controlling argument in call. Always Empty except in
3115 -- the dispatching (class-wide type) case, where it is a reference
3116 -- to the dummy object initialized to the right internal tag.
3118 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
3119 -- The expansion of the attribute reference may generate a call to
3120 -- a user-defined stream subprogram that is frozen by the call. This
3121 -- can lead to access-before-elaboration problem if the reference
3122 -- appears in an object declaration and the subprogram body has not
3123 -- been seen. The freezing of the subprogram requires special code
3124 -- because it appears in an expanded context where expressions do
3125 -- not freeze their constituents.
3127 ------------------------------
3128 -- Freeze_Stream_Subprogram --
3129 ------------------------------
3131 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
3132 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
3136 -- If this is user-defined subprogram, the corresponding
3137 -- stream function appears as a renaming-as-body, and the
3138 -- user subprogram must be retrieved by tree traversal.
3141 and then Nkind
(Decl
) = N_Subprogram_Declaration
3142 and then Present
(Corresponding_Body
(Decl
))
3144 Bod
:= Corresponding_Body
(Decl
);
3146 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3147 N_Subprogram_Renaming_Declaration
3149 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3152 end Freeze_Stream_Subprogram
;
3154 -- Start of processing for Input
3157 -- If no underlying type, we have an error that will be diagnosed
3158 -- elsewhere, so here we just completely ignore the expansion.
3164 -- If there is a TSS for Input, just call it
3166 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3168 if Present
(Fname
) then
3172 -- If there is a Stream_Convert pragma, use it, we rewrite
3174 -- sourcetyp'Input (stream)
3178 -- sourcetyp (streamread (strmtyp'Input (stream)));
3180 -- where streamread is the given Read function that converts an
3181 -- argument of type strmtyp to type sourcetyp or a type from which
3182 -- it is derived (extra conversion required for the derived case).
3184 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3186 if Present
(Prag
) then
3187 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3188 Rfunc
:= Entity
(Expression
(Arg2
));
3192 Make_Function_Call
(Loc
,
3193 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3194 Parameter_Associations
=> New_List
(
3195 Make_Attribute_Reference
(Loc
,
3198 (Etype
(First_Formal
(Rfunc
)), Loc
),
3199 Attribute_Name
=> Name_Input
,
3200 Expressions
=> Exprs
)))));
3202 Analyze_And_Resolve
(N
, B_Type
);
3207 elsif Is_Elementary_Type
(U_Type
) then
3209 -- A special case arises if we have a defined _Read routine,
3210 -- since in this case we are required to call this routine.
3212 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Read
)) then
3213 Build_Record_Or_Elementary_Input_Function
3214 (Loc
, U_Type
, Decl
, Fname
);
3215 Insert_Action
(N
, Decl
);
3217 -- For normal cases, we call the I_xxx routine directly
3220 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3221 Analyze_And_Resolve
(N
, P_Type
);
3227 elsif Is_Array_Type
(U_Type
) then
3228 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3229 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3231 -- Dispatching case with class-wide type
3233 elsif Is_Class_Wide_Type
(P_Type
) then
3235 -- No need to do anything else compiling under restriction
3236 -- No_Dispatching_Calls. During the semantic analysis we
3237 -- already notified such violation.
3239 if Restriction_Active
(No_Dispatching_Calls
) then
3244 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3250 -- Read the internal tag (RM 13.13.2(34)) and use it to
3251 -- initialize a dummy tag object:
3253 -- Dnn : Ada.Tags.Tag :=
3254 -- Descendant_Tag (String'Input (Strm), P_Type);
3256 -- This dummy object is used only to provide a controlling
3257 -- argument for the eventual _Input call. Descendant_Tag is
3258 -- called rather than Internal_Tag to ensure that we have a
3259 -- tag for a type that is descended from the prefix type and
3260 -- declared at the same accessibility level (the exception
3261 -- Tag_Error will be raised otherwise). The level check is
3262 -- required for Ada 2005 because tagged types can be
3263 -- extended in nested scopes (AI-344).
3266 Make_Function_Call
(Loc
,
3268 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3269 Parameter_Associations
=> New_List
(
3270 Make_Attribute_Reference
(Loc
,
3271 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
3272 Attribute_Name
=> Name_Input
,
3273 Expressions
=> New_List
(
3274 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
3275 Make_Attribute_Reference
(Loc
,
3276 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
3277 Attribute_Name
=> Name_Tag
)));
3279 Dnn
:= Make_Temporary
(Loc
, 'D', Expr
);
3282 Make_Object_Declaration
(Loc
,
3283 Defining_Identifier
=> Dnn
,
3284 Object_Definition
=>
3285 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
3286 Expression
=> Expr
);
3288 Insert_Action
(N
, Decl
);
3290 -- Now we need to get the entity for the call, and construct
3291 -- a function call node, where we preset a reference to Dnn
3292 -- as the controlling argument (doing an unchecked convert
3293 -- to the class-wide tagged type to make it look like a real
3296 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3298 Unchecked_Convert_To
(P_Type
,
3299 New_Occurrence_Of
(Dnn
, Loc
));
3300 Set_Etype
(Cntrl
, P_Type
);
3301 Set_Parent
(Cntrl
, N
);
3304 -- For tagged types, use the primitive Input function
3306 elsif Is_Tagged_Type
(U_Type
) then
3307 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3309 -- All other record type cases, including protected records. The
3310 -- latter only arise for expander generated code for handling
3311 -- shared passive partition access.
3315 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3317 -- Ada 2005 (AI-216): Program_Error is raised executing default
3318 -- implementation of the Input attribute of an unchecked union
3319 -- type if the type lacks default discriminant values.
3321 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3322 and then No
(Discriminant_Constraint
(U_Type
))
3325 Make_Raise_Program_Error
(Loc
,
3326 Reason
=> PE_Unchecked_Union_Restriction
));
3331 -- Build the type's Input function, passing the subtype rather
3332 -- than its base type, because checks are needed in the case of
3333 -- constrained discriminants (see Ada 2012 AI05-0192).
3335 Build_Record_Or_Elementary_Input_Function
3336 (Loc
, U_Type
, Decl
, Fname
);
3337 Insert_Action
(N
, Decl
);
3339 if Nkind
(Parent
(N
)) = N_Object_Declaration
3340 and then Is_Record_Type
(U_Type
)
3342 -- The stream function may contain calls to user-defined
3343 -- Read procedures for individual components.
3350 Comp
:= First_Component
(U_Type
);
3351 while Present
(Comp
) loop
3353 Find_Stream_Subprogram
3354 (Etype
(Comp
), TSS_Stream_Read
);
3356 if Present
(Func
) then
3357 Freeze_Stream_Subprogram
(Func
);
3360 Next_Component
(Comp
);
3367 -- If we fall through, Fname is the function to be called. The result
3368 -- is obtained by calling the appropriate function, then converting
3369 -- the result. The conversion does a subtype check.
3372 Make_Function_Call
(Loc
,
3373 Name
=> New_Occurrence_Of
(Fname
, Loc
),
3374 Parameter_Associations
=> New_List
(
3375 Relocate_Node
(Strm
)));
3377 Set_Controlling_Argument
(Call
, Cntrl
);
3378 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
3379 Analyze_And_Resolve
(N
, P_Type
);
3381 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
3382 Freeze_Stream_Subprogram
(Fname
);
3392 -- inttype'Fixed_Value (fixed-value)
3396 -- inttype(integer-value))
3398 -- we do all the required analysis of the conversion here, because we do
3399 -- not want this to go through the fixed-point conversion circuits. Note
3400 -- that the back end always treats fixed-point as equivalent to the
3401 -- corresponding integer type anyway.
3403 when Attribute_Integer_Value
=> Integer_Value
:
3406 Make_Type_Conversion
(Loc
,
3407 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3408 Expression
=> Relocate_Node
(First
(Exprs
))));
3409 Set_Etype
(N
, Entity
(Pref
));
3412 -- Note: it might appear that a properly analyzed unchecked conversion
3413 -- would be just fine here, but that's not the case, since the full
3414 -- range checks performed by the following call are critical.
3416 Apply_Type_Conversion_Checks
(N
);
3423 when Attribute_Invalid_Value
=>
3424 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
3430 when Attribute_Last
=>
3432 -- If the prefix type is a constrained packed array type which
3433 -- already has a Packed_Array_Type representation defined, then
3434 -- replace this attribute with a direct reference to 'Last of the
3435 -- appropriate index subtype (since otherwise the back end will try
3436 -- to give us the value of 'Last for this implementation type).
3438 if Is_Constrained_Packed_Array
(Ptyp
) then
3440 Make_Attribute_Reference
(Loc
,
3441 Attribute_Name
=> Name_Last
,
3442 Prefix
=> New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3443 Analyze_And_Resolve
(N
, Typ
);
3445 elsif Is_Access_Type
(Ptyp
) then
3446 Apply_Access_Check
(N
);
3453 -- We compute this if a component clause was present, otherwise we leave
3454 -- the computation up to the back end, since we don't know what layout
3457 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
3458 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3461 -- In Ada 2005 (or later) if we have the non-default bit order, then
3462 -- we return the original value as given in the component clause
3463 -- (RM 2005 13.5.2(3/2)).
3465 if Present
(Component_Clause
(CE
))
3466 and then Ada_Version
>= Ada_2005
3467 and then Reverse_Bit_Order
(Scope
(CE
))
3470 Make_Integer_Literal
(Loc
,
3471 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
3472 Analyze_And_Resolve
(N
, Typ
);
3474 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3475 -- rewrite with normalized value if we know it statically.
3477 elsif Known_Static_Component_Bit_Offset
(CE
)
3478 and then Known_Static_Esize
(CE
)
3481 Make_Integer_Literal
(Loc
,
3482 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
3484 Analyze_And_Resolve
(N
, Typ
);
3486 -- Otherwise leave to back end, just apply universal integer checks
3489 Apply_Universal_Integer_Attribute_Checks
(N
);
3497 -- Transforms 'Leading_Part into a call to the floating-point attribute
3498 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3500 -- Note: strictly, we should generate special case code to deal with
3501 -- absurdly large positive arguments (greater than Integer'Last), which
3502 -- result in returning the first argument unchanged, but it hardly seems
3503 -- worth the effort. We raise constraint error for absurdly negative
3504 -- arguments which is fine.
3506 when Attribute_Leading_Part
=>
3507 Expand_Fpt_Attribute_RI
(N
);
3513 when Attribute_Length
=> Length
: declare
3518 -- Processing for packed array types
3520 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
3521 Ityp
:= Get_Index_Subtype
(N
);
3523 -- If the index type, Ityp, is an enumeration type with holes,
3524 -- then we calculate X'Length explicitly using
3527 -- (0, Ityp'Pos (X'Last (N)) -
3528 -- Ityp'Pos (X'First (N)) + 1);
3530 -- Since the bounds in the template are the representation values
3531 -- and the back end would get the wrong value.
3533 if Is_Enumeration_Type
(Ityp
)
3534 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
3539 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
3543 Make_Attribute_Reference
(Loc
,
3544 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3545 Attribute_Name
=> Name_Max
,
3546 Expressions
=> New_List
3547 (Make_Integer_Literal
(Loc
, 0),
3551 Make_Op_Subtract
(Loc
,
3553 Make_Attribute_Reference
(Loc
,
3554 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3555 Attribute_Name
=> Name_Pos
,
3557 Expressions
=> New_List
(
3558 Make_Attribute_Reference
(Loc
,
3559 Prefix
=> Duplicate_Subexpr
(Pref
),
3560 Attribute_Name
=> Name_Last
,
3561 Expressions
=> New_List
(
3562 Make_Integer_Literal
(Loc
, Xnum
))))),
3565 Make_Attribute_Reference
(Loc
,
3566 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3567 Attribute_Name
=> Name_Pos
,
3569 Expressions
=> New_List
(
3570 Make_Attribute_Reference
(Loc
,
3572 Duplicate_Subexpr_No_Checks
(Pref
),
3573 Attribute_Name
=> Name_First
,
3574 Expressions
=> New_List
(
3575 Make_Integer_Literal
(Loc
, Xnum
)))))),
3577 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
3579 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
3582 -- If the prefix type is a constrained packed array type which
3583 -- already has a Packed_Array_Type representation defined, then
3584 -- replace this attribute with a direct reference to 'Range_Length
3585 -- of the appropriate index subtype (since otherwise the back end
3586 -- will try to give us the value of 'Length for this
3587 -- implementation type).
3589 elsif Is_Constrained
(Ptyp
) then
3591 Make_Attribute_Reference
(Loc
,
3592 Attribute_Name
=> Name_Range_Length
,
3593 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
3594 Analyze_And_Resolve
(N
, Typ
);
3599 elsif Is_Access_Type
(Ptyp
) then
3600 Apply_Access_Check
(N
);
3602 -- If the designated type is a packed array type, then we convert
3603 -- the reference to:
3606 -- xtyp'Pos (Pref'Last (Expr)) -
3607 -- xtyp'Pos (Pref'First (Expr)));
3609 -- This is a bit complex, but it is the easiest thing to do that
3610 -- works in all cases including enum types with holes xtyp here
3611 -- is the appropriate index type.
3614 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
3618 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
3619 Xtyp
:= Get_Index_Subtype
(N
);
3622 Make_Attribute_Reference
(Loc
,
3623 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3624 Attribute_Name
=> Name_Max
,
3625 Expressions
=> New_List
(
3626 Make_Integer_Literal
(Loc
, 0),
3629 Make_Integer_Literal
(Loc
, 1),
3630 Make_Op_Subtract
(Loc
,
3632 Make_Attribute_Reference
(Loc
,
3633 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
3634 Attribute_Name
=> Name_Pos
,
3635 Expressions
=> New_List
(
3636 Make_Attribute_Reference
(Loc
,
3637 Prefix
=> Duplicate_Subexpr
(Pref
),
3638 Attribute_Name
=> Name_Last
,
3640 New_Copy_List
(Exprs
)))),
3643 Make_Attribute_Reference
(Loc
,
3644 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
3645 Attribute_Name
=> Name_Pos
,
3646 Expressions
=> New_List
(
3647 Make_Attribute_Reference
(Loc
,
3649 Duplicate_Subexpr_No_Checks
(Pref
),
3650 Attribute_Name
=> Name_First
,
3652 New_Copy_List
(Exprs
)))))))));
3654 Analyze_And_Resolve
(N
, Typ
);
3658 -- Otherwise leave it to the back end
3661 Apply_Universal_Integer_Attribute_Checks
(N
);
3665 -- Attribute Loop_Entry is replaced with a reference to a constant value
3666 -- which captures the prefix at the entry point of the related loop. The
3667 -- loop itself may be transformed into a conditional block.
3669 when Attribute_Loop_Entry
=>
3670 Expand_Loop_Entry_Attribute
(N
);
3676 -- Transforms 'Machine into a call to the floating-point attribute
3677 -- function Machine in Fat_xxx (where xxx is the root type)
3679 when Attribute_Machine
=>
3680 Expand_Fpt_Attribute_R
(N
);
3682 ----------------------
3683 -- Machine_Rounding --
3684 ----------------------
3686 -- Transforms 'Machine_Rounding into a call to the floating-point
3687 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
3688 -- type). Expansion is avoided for cases the back end can handle
3691 when Attribute_Machine_Rounding
=>
3692 if not Is_Inline_Floating_Point_Attribute
(N
) then
3693 Expand_Fpt_Attribute_R
(N
);
3700 -- Machine_Size is equivalent to Object_Size, so transform it into
3701 -- Object_Size and that way the back end never sees Machine_Size.
3703 when Attribute_Machine_Size
=>
3705 Make_Attribute_Reference
(Loc
,
3706 Prefix
=> Prefix
(N
),
3707 Attribute_Name
=> Name_Object_Size
));
3709 Analyze_And_Resolve
(N
, Typ
);
3715 -- The only case that can get this far is the dynamic case of the old
3716 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
3723 -- ityp (System.Mantissa.Mantissa_Value
3724 -- (Integer'Integer_Value (typ'First),
3725 -- Integer'Integer_Value (typ'Last)));
3727 when Attribute_Mantissa
=> Mantissa
: begin
3730 Make_Function_Call
(Loc
,
3731 Name
=> New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
3733 Parameter_Associations
=> New_List
(
3735 Make_Attribute_Reference
(Loc
,
3736 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
3737 Attribute_Name
=> Name_Integer_Value
,
3738 Expressions
=> New_List
(
3740 Make_Attribute_Reference
(Loc
,
3741 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3742 Attribute_Name
=> Name_First
))),
3744 Make_Attribute_Reference
(Loc
,
3745 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
3746 Attribute_Name
=> Name_Integer_Value
,
3747 Expressions
=> New_List
(
3749 Make_Attribute_Reference
(Loc
,
3750 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3751 Attribute_Name
=> Name_Last
)))))));
3753 Analyze_And_Resolve
(N
, Typ
);
3760 when Attribute_Max
=>
3761 Expand_Min_Max_Attribute
(N
);
3763 ----------------------------------
3764 -- Max_Size_In_Storage_Elements --
3765 ----------------------------------
3767 when Attribute_Max_Size_In_Storage_Elements
=> declare
3768 Typ
: constant Entity_Id
:= Etype
(N
);
3771 Conversion_Added
: Boolean := False;
3772 -- A flag which tracks whether the original attribute has been
3773 -- wrapped inside a type conversion.
3776 Apply_Universal_Integer_Attribute_Checks
(N
);
3778 -- The universal integer check may sometimes add a type conversion,
3779 -- retrieve the original attribute reference from the expression.
3782 if Nkind
(Attr
) = N_Type_Conversion
then
3783 Attr
:= Expression
(Attr
);
3784 Conversion_Added
:= True;
3787 -- Heap-allocated controlled objects contain two extra pointers which
3788 -- are not part of the actual type. Transform the attribute reference
3789 -- into a runtime expression to add the size of the hidden header.
3791 -- Do not perform this expansion on .NET/JVM targets because the
3792 -- two pointers are already present in the type.
3794 if VM_Target
= No_VM
3795 and then Nkind
(Attr
) = N_Attribute_Reference
3796 and then Needs_Finalization
(Ptyp
)
3797 and then not Header_Size_Added
(Attr
)
3799 Set_Header_Size_Added
(Attr
);
3802 -- P'Max_Size_In_Storage_Elements +
3803 -- Universal_Integer
3804 -- (Header_Size_With_Padding (Ptyp'Alignment))
3808 Left_Opnd
=> Relocate_Node
(Attr
),
3810 Convert_To
(Universal_Integer
,
3811 Make_Function_Call
(Loc
,
3814 (RTE
(RE_Header_Size_With_Padding
), Loc
),
3816 Parameter_Associations
=> New_List
(
3817 Make_Attribute_Reference
(Loc
,
3819 New_Occurrence_Of
(Ptyp
, Loc
),
3820 Attribute_Name
=> Name_Alignment
))))));
3822 -- Add a conversion to the target type
3824 if not Conversion_Added
then
3826 Make_Type_Conversion
(Loc
,
3827 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
3828 Expression
=> Relocate_Node
(Attr
)));
3836 --------------------
3837 -- Mechanism_Code --
3838 --------------------
3840 when Attribute_Mechanism_Code
=>
3842 -- We must replace the prefix i the renamed case
3844 if Is_Entity_Name
(Pref
)
3845 and then Present
(Alias
(Entity
(Pref
)))
3847 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
3854 when Attribute_Min
=>
3855 Expand_Min_Max_Attribute
(N
);
3861 when Attribute_Mod
=> Mod_Case
: declare
3862 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
3863 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
3864 Modv
: constant Uint
:= Modulus
(Btyp
);
3868 -- This is not so simple. The issue is what type to use for the
3869 -- computation of the modular value.
3871 -- The easy case is when the modulus value is within the bounds
3872 -- of the signed integer type of the argument. In this case we can
3873 -- just do the computation in that signed integer type, and then
3874 -- do an ordinary conversion to the target type.
3876 if Modv
<= Expr_Value
(Hi
) then
3881 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
3883 -- Here we know that the modulus is larger than type'Last of the
3884 -- integer type. There are two cases to consider:
3886 -- a) The integer value is non-negative. In this case, it is
3887 -- returned as the result (since it is less than the modulus).
3889 -- b) The integer value is negative. In this case, we know that the
3890 -- result is modulus + value, where the value might be as small as
3891 -- -modulus. The trouble is what type do we use to do the subtract.
3892 -- No type will do, since modulus can be as big as 2**64, and no
3893 -- integer type accommodates this value. Let's do bit of algebra
3896 -- = modulus - (-value)
3897 -- = (modulus - 1) - (-value - 1)
3899 -- Now modulus - 1 is certainly in range of the modular type.
3900 -- -value is in the range 1 .. modulus, so -value -1 is in the
3901 -- range 0 .. modulus-1 which is in range of the modular type.
3902 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
3903 -- which we can compute using the integer base type.
3905 -- Once this is done we analyze the if expression without range
3906 -- checks, because we know everything is in range, and we want
3907 -- to prevent spurious warnings on either branch.
3911 Make_If_Expression
(Loc
,
3912 Expressions
=> New_List
(
3914 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
3915 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3918 Duplicate_Subexpr_No_Checks
(Arg
)),
3920 Make_Op_Subtract
(Loc
,
3922 Make_Integer_Literal
(Loc
,
3923 Intval
=> Modv
- 1),
3929 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
3931 Make_Integer_Literal
(Loc
,
3932 Intval
=> 1))))))));
3936 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
3943 -- Transforms 'Model into a call to the floating-point attribute
3944 -- function Model in Fat_xxx (where xxx is the root type)
3946 when Attribute_Model
=>
3947 Expand_Fpt_Attribute_R
(N
);
3953 -- The processing for Object_Size shares the processing for Size
3959 when Attribute_Old
=> Old
: declare
3965 -- If assertions are disabled, no need to create the declaration
3966 -- that preserves the value.
3968 if not Assertions_Enabled
then
3972 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
3974 -- Climb the parent chain looking for subprogram _Postconditions
3977 while Present
(Subp
) loop
3978 exit when Nkind
(Subp
) = N_Subprogram_Body
3979 and then Chars
(Defining_Entity
(Subp
)) = Name_uPostconditions
;
3981 Subp
:= Parent
(Subp
);
3984 -- 'Old can only appear in a postcondition, the generated body of
3985 -- _Postconditions must be in the tree.
3987 pragma Assert
(Present
(Subp
));
3990 -- Temp : constant <Pref type> := <Pref>;
3993 Make_Object_Declaration
(Loc
,
3994 Defining_Identifier
=> Temp
,
3995 Constant_Present
=> True,
3996 Object_Definition
=> New_Occurrence_Of
(Etype
(N
), Loc
),
3997 Expression
=> Pref
);
3999 -- Push the scope of the related subprogram where _Postcondition
4000 -- resides as this ensures that the object will be analyzed in the
4003 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
4005 -- The object declaration is inserted before the body of subprogram
4006 -- _Postconditions. This ensures that any precondition-like actions
4007 -- are still executed before any parameter values are captured and
4008 -- the multiple 'Old occurrences appear in order of declaration.
4010 Insert_Before_And_Analyze
(Subp
, Asn_Stm
);
4013 -- Ensure that the prefix of attribute 'Old is valid. The check must
4014 -- be inserted after the expansion of the attribute has taken place
4015 -- to reflect the new placement of the prefix.
4017 if Validity_Checks_On
and then Validity_Check_Operands
then
4018 Ensure_Valid
(Pref
);
4021 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4024 ----------------------
4025 -- Overlaps_Storage --
4026 ----------------------
4028 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
4029 Loc
: constant Source_Ptr
:= Sloc
(N
);
4031 X
: constant Node_Id
:= Prefix
(N
);
4032 Y
: constant Node_Id
:= First
(Expressions
(N
));
4035 X_Addr
, Y_Addr
: Node_Id
;
4036 -- the expressions for their integer addresses
4038 X_Size
, Y_Size
: Node_Id
;
4039 -- the expressions for their sizes
4044 -- Attribute expands into:
4046 -- if X'Address < Y'address then
4047 -- (X'address + X'Size - 1) >= Y'address
4049 -- (Y'address + Y'size - 1) >= X'Address
4052 -- with the proper address operations. We convert addresses to
4053 -- integer addresses to use predefined arithmetic. The size is
4054 -- expressed in storage units.
4057 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4058 Make_Attribute_Reference
(Loc
,
4059 Attribute_Name
=> Name_Address
,
4060 Prefix
=> New_Copy_Tree
(X
)));
4063 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
4064 Make_Attribute_Reference
(Loc
,
4065 Attribute_Name
=> Name_Address
,
4066 Prefix
=> New_Copy_Tree
(Y
)));
4069 Make_Op_Divide
(Loc
,
4071 Make_Attribute_Reference
(Loc
,
4072 Attribute_Name
=> Name_Size
,
4073 Prefix
=> New_Copy_Tree
(X
)),
4075 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4078 Make_Op_Divide
(Loc
,
4080 Make_Attribute_Reference
(Loc
,
4081 Attribute_Name
=> Name_Size
,
4082 Prefix
=> New_Copy_Tree
(Y
)),
4084 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
4088 Left_Opnd
=> X_Addr
,
4089 Right_Opnd
=> Y_Addr
);
4092 Make_If_Expression
(Loc
,
4099 Left_Opnd
=> X_Addr
,
4101 Make_Op_Subtract
(Loc
,
4102 Left_Opnd
=> X_Size
,
4103 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4104 Right_Opnd
=> Y_Addr
),
4108 Left_Opnd
=> Y_Addr
,
4110 Make_Op_Subtract
(Loc
,
4111 Left_Opnd
=> Y_Size
,
4112 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
4113 Right_Opnd
=> X_Addr
))));
4115 Analyze_And_Resolve
(N
, Standard_Boolean
);
4116 end Overlaps_Storage
;
4122 when Attribute_Output
=> Output
: declare
4123 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4124 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4132 -- If no underlying type, we have an error that will be diagnosed
4133 -- elsewhere, so here we just completely ignore the expansion.
4139 -- If TSS for Output is present, just call it
4141 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
4143 if Present
(Pname
) then
4147 -- If there is a Stream_Convert pragma, use it, we rewrite
4149 -- sourcetyp'Output (stream, Item)
4153 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4155 -- where strmwrite is the given Write function that converts an
4156 -- argument of type sourcetyp or a type acctyp, from which it is
4157 -- derived to type strmtyp. The conversion to acttyp is required
4158 -- for the derived case.
4160 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4162 if Present
(Prag
) then
4164 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4165 Wfunc
:= Entity
(Expression
(Arg3
));
4168 Make_Attribute_Reference
(Loc
,
4169 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4170 Attribute_Name
=> Name_Output
,
4171 Expressions
=> New_List
(
4172 Relocate_Node
(First
(Exprs
)),
4173 Make_Function_Call
(Loc
,
4174 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4175 Parameter_Associations
=> New_List
(
4176 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4177 Relocate_Node
(Next
(First
(Exprs
)))))))));
4182 -- For elementary types, we call the W_xxx routine directly.
4183 -- Note that the effect of Write and Output is identical for
4184 -- the case of an elementary type, since there are no
4185 -- discriminants or bounds.
4187 elsif Is_Elementary_Type
(U_Type
) then
4189 -- A special case arises if we have a defined _Write routine,
4190 -- since in this case we are required to call this routine.
4192 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Write
)) then
4193 Build_Record_Or_Elementary_Output_Procedure
4194 (Loc
, U_Type
, Decl
, Pname
);
4195 Insert_Action
(N
, Decl
);
4197 -- For normal cases, we call the W_xxx routine directly
4200 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4207 elsif Is_Array_Type
(U_Type
) then
4208 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4209 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4211 -- Class-wide case, first output external tag, then dispatch
4212 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4214 elsif Is_Class_Wide_Type
(P_Type
) then
4216 -- No need to do anything else compiling under restriction
4217 -- No_Dispatching_Calls. During the semantic analysis we
4218 -- already notified such violation.
4220 if Restriction_Active
(No_Dispatching_Calls
) then
4225 Strm
: constant Node_Id
:= First
(Exprs
);
4226 Item
: constant Node_Id
:= Next
(Strm
);
4229 -- Ada 2005 (AI-344): Check that the accessibility level
4230 -- of the type of the output object is not deeper than
4231 -- that of the attribute's prefix type.
4233 -- if Get_Access_Level (Item'Tag)
4234 -- /= Get_Access_Level (P_Type'Tag)
4239 -- String'Output (Strm, External_Tag (Item'Tag));
4241 -- We cannot figure out a practical way to implement this
4242 -- accessibility check on virtual machines, so we omit it.
4244 if Ada_Version
>= Ada_2005
4245 and then Tagged_Type_Expansion
4248 Make_Implicit_If_Statement
(N
,
4252 Build_Get_Access_Level
(Loc
,
4253 Make_Attribute_Reference
(Loc
,
4256 Duplicate_Subexpr
(Item
,
4258 Attribute_Name
=> Name_Tag
)),
4261 Make_Integer_Literal
(Loc
,
4262 Type_Access_Level
(P_Type
))),
4265 New_List
(Make_Raise_Statement
(Loc
,
4267 RTE
(RE_Tag_Error
), Loc
)))));
4271 Make_Attribute_Reference
(Loc
,
4272 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
4273 Attribute_Name
=> Name_Output
,
4274 Expressions
=> New_List
(
4275 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
4276 Make_Function_Call
(Loc
,
4278 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
4279 Parameter_Associations
=> New_List
(
4280 Make_Attribute_Reference
(Loc
,
4283 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
4284 Attribute_Name
=> Name_Tag
))))));
4287 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4289 -- Tagged type case, use the primitive Output function
4291 elsif Is_Tagged_Type
(U_Type
) then
4292 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4294 -- All other record type cases, including protected records.
4295 -- The latter only arise for expander generated code for
4296 -- handling shared passive partition access.
4300 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4302 -- Ada 2005 (AI-216): Program_Error is raised when executing
4303 -- the default implementation of the Output attribute of an
4304 -- unchecked union type if the type lacks default discriminant
4307 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4308 and then No
(Discriminant_Constraint
(U_Type
))
4311 Make_Raise_Program_Error
(Loc
,
4312 Reason
=> PE_Unchecked_Union_Restriction
));
4317 Build_Record_Or_Elementary_Output_Procedure
4318 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
4319 Insert_Action
(N
, Decl
);
4323 -- If we fall through, Pname is the name of the procedure to call
4325 Rewrite_Stream_Proc_Call
(Pname
);
4332 -- For enumeration types with a standard representation, Pos is
4333 -- handled by the back end.
4335 -- For enumeration types, with a non-standard representation we generate
4336 -- a call to the _Rep_To_Pos function created when the type was frozen.
4337 -- The call has the form
4339 -- _rep_to_pos (expr, flag)
4341 -- The parameter flag is True if range checks are enabled, causing
4342 -- Program_Error to be raised if the expression has an invalid
4343 -- representation, and False if range checks are suppressed.
4345 -- For integer types, Pos is equivalent to a simple integer
4346 -- conversion and we rewrite it as such
4348 when Attribute_Pos
=> Pos
:
4350 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
4353 -- Deal with zero/non-zero boolean values
4355 if Is_Boolean_Type
(Etyp
) then
4356 Adjust_Condition
(First
(Exprs
));
4357 Etyp
:= Standard_Boolean
;
4358 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
4361 -- Case of enumeration type
4363 if Is_Enumeration_Type
(Etyp
) then
4365 -- Non-standard enumeration type (generate call)
4367 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
4368 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
4371 Make_Function_Call
(Loc
,
4373 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4374 Parameter_Associations
=> Exprs
)));
4376 Analyze_And_Resolve
(N
, Typ
);
4378 -- Standard enumeration type (do universal integer check)
4381 Apply_Universal_Integer_Attribute_Checks
(N
);
4384 -- Deal with integer types (replace by conversion)
4386 elsif Is_Integer_Type
(Etyp
) then
4387 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
4388 Analyze_And_Resolve
(N
, Typ
);
4397 -- We compute this if a component clause was present, otherwise we leave
4398 -- the computation up to the back end, since we don't know what layout
4401 when Attribute_Position
=> Position_Attr
:
4403 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4406 if Present
(Component_Clause
(CE
)) then
4408 -- In Ada 2005 (or later) if we have the non-default bit order,
4409 -- then we return the original value as given in the component
4410 -- clause (RM 2005 13.5.2(2/2)).
4412 if Ada_Version
>= Ada_2005
4413 and then Reverse_Bit_Order
(Scope
(CE
))
4416 Make_Integer_Literal
(Loc
,
4417 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
4419 -- Otherwise (Ada 83 or 95, or default bit order specified in
4420 -- later Ada version), return the normalized value.
4424 Make_Integer_Literal
(Loc
,
4425 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
4428 Analyze_And_Resolve
(N
, Typ
);
4430 -- If back end is doing things, just apply universal integer checks
4433 Apply_Universal_Integer_Attribute_Checks
(N
);
4441 -- 1. Deal with enumeration types with holes
4442 -- 2. For floating-point, generate call to attribute function
4443 -- 3. For other cases, deal with constraint checking
4445 when Attribute_Pred
=> Pred
:
4447 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
4451 -- For enumeration types with non-standard representations, we
4452 -- expand typ'Pred (x) into
4454 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4456 -- If the representation is contiguous, we compute instead
4457 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4458 -- The conversion function Enum_Pos_To_Rep is defined on the
4459 -- base type, not the subtype, so we have to use the base type
4460 -- explicitly for this and other enumeration attributes.
4462 if Is_Enumeration_Type
(Ptyp
)
4463 and then Present
(Enum_Pos_To_Rep
(Etyp
))
4465 if Has_Contiguous_Rep
(Etyp
) then
4467 Unchecked_Convert_To
(Ptyp
,
4470 Make_Integer_Literal
(Loc
,
4471 Enumeration_Rep
(First_Literal
(Ptyp
))),
4473 Make_Function_Call
(Loc
,
4476 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4478 Parameter_Associations
=>
4480 Unchecked_Convert_To
(Ptyp
,
4481 Make_Op_Subtract
(Loc
,
4483 Unchecked_Convert_To
(Standard_Integer
,
4484 Relocate_Node
(First
(Exprs
))),
4486 Make_Integer_Literal
(Loc
, 1))),
4487 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
4490 -- Add Boolean parameter True, to request program errror if
4491 -- we have a bad representation on our hands. If checks are
4492 -- suppressed, then add False instead
4494 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
4496 Make_Indexed_Component
(Loc
,
4499 (Enum_Pos_To_Rep
(Etyp
), Loc
),
4500 Expressions
=> New_List
(
4501 Make_Op_Subtract
(Loc
,
4503 Make_Function_Call
(Loc
,
4506 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4507 Parameter_Associations
=> Exprs
),
4508 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4511 Analyze_And_Resolve
(N
, Typ
);
4513 -- For floating-point, we transform 'Pred into a call to the Pred
4514 -- floating-point attribute function in Fat_xxx (xxx is root type)
4516 elsif Is_Floating_Point_Type
(Ptyp
) then
4517 Expand_Fpt_Attribute_R
(N
);
4518 Analyze_And_Resolve
(N
, Typ
);
4520 -- For modular types, nothing to do (no overflow, since wraps)
4522 elsif Is_Modular_Integer_Type
(Ptyp
) then
4525 -- For other types, if argument is marked as needing a range check or
4526 -- overflow checking is enabled, we must generate a check.
4528 elsif not Overflow_Checks_Suppressed
(Ptyp
)
4529 or else Do_Range_Check
(First
(Exprs
))
4531 Set_Do_Range_Check
(First
(Exprs
), False);
4532 Expand_Pred_Succ_Attribute
(N
);
4540 -- Ada 2005 (AI-327): Dynamic ceiling priorities
4542 -- We rewrite X'Priority as the following run-time call:
4544 -- Get_Ceiling (X._Object)
4546 -- Note that although X'Priority is notionally an object, it is quite
4547 -- deliberately not defined as an aliased object in the RM. This means
4548 -- that it works fine to rewrite it as a call, without having to worry
4549 -- about complications that would other arise from X'Priority'Access,
4550 -- which is illegal, because of the lack of aliasing.
4552 when Attribute_Priority
=>
4555 Conctyp
: Entity_Id
;
4556 Object_Parm
: Node_Id
;
4558 RT_Subprg_Name
: Node_Id
;
4561 -- Look for the enclosing concurrent type
4563 Conctyp
:= Current_Scope
;
4564 while not Is_Concurrent_Type
(Conctyp
) loop
4565 Conctyp
:= Scope
(Conctyp
);
4568 pragma Assert
(Is_Protected_Type
(Conctyp
));
4570 -- Generate the actual of the call
4572 Subprg
:= Current_Scope
;
4573 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
4574 Subprg
:= Scope
(Subprg
);
4577 -- Use of 'Priority inside protected entries and barriers (in
4578 -- both cases the type of the first formal of their expanded
4579 -- subprogram is Address)
4581 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
)))
4585 New_Itype
: Entity_Id
;
4588 -- In the expansion of protected entries the type of the
4589 -- first formal of the Protected_Body_Subprogram is an
4590 -- Address. In order to reference the _object component
4593 -- type T is access p__ptTV;
4596 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
4597 Set_Etype
(New_Itype
, New_Itype
);
4598 Set_Directly_Designated_Type
(New_Itype
,
4599 Corresponding_Record_Type
(Conctyp
));
4600 Freeze_Itype
(New_Itype
, N
);
4603 -- T!(O)._object'unchecked_access
4606 Make_Attribute_Reference
(Loc
,
4608 Make_Selected_Component
(Loc
,
4610 Unchecked_Convert_To
(New_Itype
,
4613 (Protected_Body_Subprogram
(Subprg
)),
4616 Make_Identifier
(Loc
, Name_uObject
)),
4617 Attribute_Name
=> Name_Unchecked_Access
);
4620 -- Use of 'Priority inside a protected subprogram
4624 Make_Attribute_Reference
(Loc
,
4626 Make_Selected_Component
(Loc
,
4627 Prefix
=> New_Occurrence_Of
4629 (Protected_Body_Subprogram
(Subprg
)),
4631 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4632 Attribute_Name
=> Name_Unchecked_Access
);
4635 -- Select the appropriate run-time subprogram
4637 if Number_Entries
(Conctyp
) = 0 then
4639 New_Occurrence_Of
(RTE
(RE_Get_Ceiling
), Loc
);
4642 New_Occurrence_Of
(RTE
(RO_PE_Get_Ceiling
), Loc
);
4646 Make_Function_Call
(Loc
,
4647 Name
=> RT_Subprg_Name
,
4648 Parameter_Associations
=> New_List
(Object_Parm
));
4652 -- Avoid the generation of extra checks on the pointer to the
4653 -- protected object.
4655 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
4662 when Attribute_Range_Length
=> Range_Length
: begin
4664 -- The only special processing required is for the case where
4665 -- Range_Length is applied to an enumeration type with holes.
4666 -- In this case we transform
4672 -- X'Pos (X'Last) - X'Pos (X'First) + 1
4674 -- So that the result reflects the proper Pos values instead
4675 -- of the underlying representations.
4677 if Is_Enumeration_Type
(Ptyp
)
4678 and then Has_Non_Standard_Rep
(Ptyp
)
4683 Make_Op_Subtract
(Loc
,
4685 Make_Attribute_Reference
(Loc
,
4686 Attribute_Name
=> Name_Pos
,
4687 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4688 Expressions
=> New_List
(
4689 Make_Attribute_Reference
(Loc
,
4690 Attribute_Name
=> Name_Last
,
4691 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
)))),
4694 Make_Attribute_Reference
(Loc
,
4695 Attribute_Name
=> Name_Pos
,
4696 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4697 Expressions
=> New_List
(
4698 Make_Attribute_Reference
(Loc
,
4699 Attribute_Name
=> Name_First
,
4700 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
))))),
4702 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
4704 Analyze_And_Resolve
(N
, Typ
);
4706 -- For all other cases, the attribute is handled by the back end, but
4707 -- we need to deal with the case of the range check on a universal
4711 Apply_Universal_Integer_Attribute_Checks
(N
);
4719 when Attribute_Read
=> Read
: declare
4720 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4721 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
4722 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4732 -- If no underlying type, we have an error that will be diagnosed
4733 -- elsewhere, so here we just completely ignore the expansion.
4739 -- The simple case, if there is a TSS for Read, just call it
4741 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
4743 if Present
(Pname
) then
4747 -- If there is a Stream_Convert pragma, use it, we rewrite
4749 -- sourcetyp'Read (stream, Item)
4753 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
4755 -- where strmread is the given Read function that converts an
4756 -- argument of type strmtyp to type sourcetyp or a type from which
4757 -- it is derived. The conversion to sourcetyp is required in the
4760 -- A special case arises if Item is a type conversion in which
4761 -- case, we have to expand to:
4763 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
4765 -- where Itemx is the expression of the type conversion (i.e.
4766 -- the actual object), and typex is the type of Itemx.
4768 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4770 if Present
(Prag
) then
4771 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4772 Rfunc
:= Entity
(Expression
(Arg2
));
4773 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
4775 OK_Convert_To
(B_Type
,
4776 Make_Function_Call
(Loc
,
4777 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4778 Parameter_Associations
=> New_List
(
4779 Make_Attribute_Reference
(Loc
,
4782 (Etype
(First_Formal
(Rfunc
)), Loc
),
4783 Attribute_Name
=> Name_Input
,
4784 Expressions
=> New_List
(
4785 Relocate_Node
(First
(Exprs
)))))));
4787 if Nkind
(Lhs
) = N_Type_Conversion
then
4788 Lhs
:= Expression
(Lhs
);
4789 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
4793 Make_Assignment_Statement
(Loc
,
4795 Expression
=> Rhs
));
4796 Set_Assignment_OK
(Lhs
);
4800 -- For elementary types, we call the I_xxx routine using the first
4801 -- parameter and then assign the result into the second parameter.
4802 -- We set Assignment_OK to deal with the conversion case.
4804 elsif Is_Elementary_Type
(U_Type
) then
4810 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
4811 Rhs
:= Build_Elementary_Input_Call
(N
);
4813 if Nkind
(Lhs
) = N_Type_Conversion
then
4814 Lhs
:= Expression
(Lhs
);
4815 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
4818 Set_Assignment_OK
(Lhs
);
4821 Make_Assignment_Statement
(Loc
,
4823 Expression
=> Rhs
));
4831 elsif Is_Array_Type
(U_Type
) then
4832 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
4833 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4835 -- Tagged type case, use the primitive Read function. Note that
4836 -- this will dispatch in the class-wide case which is what we want
4838 elsif Is_Tagged_Type
(U_Type
) then
4839 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
4841 -- All other record type cases, including protected records. The
4842 -- latter only arise for expander generated code for handling
4843 -- shared passive partition access.
4847 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4849 -- Ada 2005 (AI-216): Program_Error is raised when executing
4850 -- the default implementation of the Read attribute of an
4851 -- Unchecked_Union type.
4853 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
4855 Make_Raise_Program_Error
(Loc
,
4856 Reason
=> PE_Unchecked_Union_Restriction
));
4859 if Has_Discriminants
(U_Type
)
4861 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
4863 Build_Mutable_Record_Read_Procedure
4864 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
4866 Build_Record_Read_Procedure
4867 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
4870 -- Suppress checks, uninitialized or otherwise invalid
4871 -- data does not cause constraint errors to be raised for
4872 -- a complete record read.
4874 Insert_Action
(N
, Decl
, All_Checks
);
4878 Rewrite_Stream_Proc_Call
(Pname
);
4885 -- Ref is identical to To_Address, see To_Address for processing
4891 -- Transforms 'Remainder into a call to the floating-point attribute
4892 -- function Remainder in Fat_xxx (where xxx is the root type)
4894 when Attribute_Remainder
=>
4895 Expand_Fpt_Attribute_RR
(N
);
4901 -- Transform 'Result into reference to _Result formal. At the point
4902 -- where a legal 'Result attribute is expanded, we know that we are in
4903 -- the context of a _Postcondition function with a _Result parameter.
4905 when Attribute_Result
=>
4906 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
4907 Analyze_And_Resolve
(N
, Typ
);
4913 -- The handling of the Round attribute is quite delicate. The processing
4914 -- in Sem_Attr introduced a conversion to universal real, reflecting the
4915 -- semantics of Round, but we do not want anything to do with universal
4916 -- real at runtime, since this corresponds to using floating-point
4919 -- What we have now is that the Etype of the Round attribute correctly
4920 -- indicates the final result type. The operand of the Round is the
4921 -- conversion to universal real, described above, and the operand of
4922 -- this conversion is the actual operand of Round, which may be the
4923 -- special case of a fixed point multiplication or division (Etype =
4926 -- The exapander will expand first the operand of the conversion, then
4927 -- the conversion, and finally the round attribute itself, since we
4928 -- always work inside out. But we cannot simply process naively in this
4929 -- order. In the semantic world where universal fixed and real really
4930 -- exist and have infinite precision, there is no problem, but in the
4931 -- implementation world, where universal real is a floating-point type,
4932 -- we would get the wrong result.
4934 -- So the approach is as follows. First, when expanding a multiply or
4935 -- divide whose type is universal fixed, we do nothing at all, instead
4936 -- deferring the operation till later.
4938 -- The actual processing is done in Expand_N_Type_Conversion which
4939 -- handles the special case of Round by looking at its parent to see if
4940 -- it is a Round attribute, and if it is, handling the conversion (or
4941 -- its fixed multiply/divide child) in an appropriate manner.
4943 -- This means that by the time we get to expanding the Round attribute
4944 -- itself, the Round is nothing more than a type conversion (and will
4945 -- often be a null type conversion), so we just replace it with the
4946 -- appropriate conversion operation.
4948 when Attribute_Round
=>
4950 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
4951 Analyze_And_Resolve
(N
);
4957 -- Transforms 'Rounding into a call to the floating-point attribute
4958 -- function Rounding in Fat_xxx (where xxx is the root type)
4960 when Attribute_Rounding
=>
4961 Expand_Fpt_Attribute_R
(N
);
4967 when Attribute_Same_Storage
=> Same_Storage
: declare
4968 Loc
: constant Source_Ptr
:= Sloc
(N
);
4970 X
: constant Node_Id
:= Prefix
(N
);
4971 Y
: constant Node_Id
:= First
(Expressions
(N
));
4974 X_Addr
, Y_Addr
: Node_Id
;
4975 -- Rhe expressions for their addresses
4977 X_Size
, Y_Size
: Node_Id
;
4978 -- Rhe expressions for their sizes
4981 -- The attribute is expanded as:
4983 -- (X'address = Y'address)
4984 -- and then (X'Size = Y'Size)
4986 -- If both arguments have the same Etype the second conjunct can be
4990 Make_Attribute_Reference
(Loc
,
4991 Attribute_Name
=> Name_Address
,
4992 Prefix
=> New_Copy_Tree
(X
));
4995 Make_Attribute_Reference
(Loc
,
4996 Attribute_Name
=> Name_Address
,
4997 Prefix
=> New_Copy_Tree
(Y
));
5000 Make_Attribute_Reference
(Loc
,
5001 Attribute_Name
=> Name_Size
,
5002 Prefix
=> New_Copy_Tree
(X
));
5005 Make_Attribute_Reference
(Loc
,
5006 Attribute_Name
=> Name_Size
,
5007 Prefix
=> New_Copy_Tree
(Y
));
5009 if Etype
(X
) = Etype
(Y
) then
5012 Left_Opnd
=> X_Addr
,
5013 Right_Opnd
=> Y_Addr
)));
5019 Left_Opnd
=> X_Addr
,
5020 Right_Opnd
=> Y_Addr
),
5023 Left_Opnd
=> X_Size
,
5024 Right_Opnd
=> Y_Size
)));
5027 Analyze_And_Resolve
(N
, Standard_Boolean
);
5034 -- Transforms 'Scaling into a call to the floating-point attribute
5035 -- function Scaling in Fat_xxx (where xxx is the root type)
5037 when Attribute_Scaling
=>
5038 Expand_Fpt_Attribute_RI
(N
);
5040 -------------------------
5041 -- Simple_Storage_Pool --
5042 -------------------------
5044 when Attribute_Simple_Storage_Pool
=>
5046 Make_Type_Conversion
(Loc
,
5047 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5048 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5049 Analyze_And_Resolve
(N
, Typ
);
5055 when Attribute_Size |
5056 Attribute_Object_Size |
5057 Attribute_Value_Size |
5058 Attribute_VADS_Size
=> Size
:
5065 -- Processing for VADS_Size case. Note that this processing removes
5066 -- all traces of VADS_Size from the tree, and completes all required
5067 -- processing for VADS_Size by translating the attribute reference
5068 -- to an appropriate Size or Object_Size reference.
5070 if Id
= Attribute_VADS_Size
5071 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
5073 -- If the size is specified, then we simply use the specified
5074 -- size. This applies to both types and objects. The size of an
5075 -- object can be specified in the following ways:
5077 -- An explicit size object is given for an object
5078 -- A component size is specified for an indexed component
5079 -- A component clause is specified for a selected component
5080 -- The object is a component of a packed composite object
5082 -- If the size is specified, then VADS_Size of an object
5084 if (Is_Entity_Name
(Pref
)
5085 and then Present
(Size_Clause
(Entity
(Pref
))))
5087 (Nkind
(Pref
) = N_Component_Clause
5088 and then (Present
(Component_Clause
5089 (Entity
(Selector_Name
(Pref
))))
5090 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5092 (Nkind
(Pref
) = N_Indexed_Component
5093 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
5094 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
5096 Set_Attribute_Name
(N
, Name_Size
);
5098 -- Otherwise if we have an object rather than a type, then the
5099 -- VADS_Size attribute applies to the type of the object, rather
5100 -- than the object itself. This is one of the respects in which
5101 -- VADS_Size differs from Size.
5104 if (not Is_Entity_Name
(Pref
)
5105 or else not Is_Type
(Entity
(Pref
)))
5106 and then (Is_Scalar_Type
(Ptyp
) or else Is_Constrained
(Ptyp
))
5108 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
5111 -- For a scalar type for which no size was explicitly given,
5112 -- VADS_Size means Object_Size. This is the other respect in
5113 -- which VADS_Size differs from Size.
5115 if Is_Scalar_Type
(Ptyp
) and then No
(Size_Clause
(Ptyp
)) then
5116 Set_Attribute_Name
(N
, Name_Object_Size
);
5118 -- In all other cases, Size and VADS_Size are the sane
5121 Set_Attribute_Name
(N
, Name_Size
);
5126 -- For class-wide types, X'Class'Size is transformed into a direct
5127 -- reference to the Size of the class type, so that the back end does
5128 -- not have to deal with the X'Class'Size reference.
5130 if Is_Entity_Name
(Pref
)
5131 and then Is_Class_Wide_Type
(Entity
(Pref
))
5133 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
5136 -- For X'Size applied to an object of a class-wide type, transform
5137 -- X'Size into a call to the primitive operation _Size applied to X.
5139 elsif Is_Class_Wide_Type
(Ptyp
)
5140 or else (Id
= Attribute_Size
5141 and then Is_Tagged_Type
(Ptyp
)
5142 and then Has_Unknown_Discriminants
(Ptyp
))
5144 -- No need to do anything else compiling under restriction
5145 -- No_Dispatching_Calls. During the semantic analysis we
5146 -- already notified such violation.
5148 if Restriction_Active
(No_Dispatching_Calls
) then
5153 Make_Function_Call
(Loc
,
5154 Name
=> New_Occurrence_Of
5155 (Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
5156 Parameter_Associations
=> New_List
(Pref
));
5158 if Typ
/= Standard_Long_Long_Integer
then
5160 -- The context is a specific integer type with which the
5161 -- original attribute was compatible. The function has a
5162 -- specific type as well, so to preserve the compatibility
5163 -- we must convert explicitly.
5165 New_Node
:= Convert_To
(Typ
, New_Node
);
5168 Rewrite
(N
, New_Node
);
5169 Analyze_And_Resolve
(N
, Typ
);
5172 -- Case of known RM_Size of a type
5174 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
5175 and then Is_Entity_Name
(Pref
)
5176 and then Is_Type
(Entity
(Pref
))
5177 and then Known_Static_RM_Size
(Entity
(Pref
))
5179 Siz
:= RM_Size
(Entity
(Pref
));
5181 -- Case of known Esize of a type
5183 elsif Id
= Attribute_Object_Size
5184 and then Is_Entity_Name
(Pref
)
5185 and then Is_Type
(Entity
(Pref
))
5186 and then Known_Static_Esize
(Entity
(Pref
))
5188 Siz
:= Esize
(Entity
(Pref
));
5190 -- Case of known size of object
5192 elsif Id
= Attribute_Size
5193 and then Is_Entity_Name
(Pref
)
5194 and then Is_Object
(Entity
(Pref
))
5195 and then Known_Esize
(Entity
(Pref
))
5196 and then Known_Static_Esize
(Entity
(Pref
))
5198 Siz
:= Esize
(Entity
(Pref
));
5200 -- For an array component, we can do Size in the front end
5201 -- if the component_size of the array is set.
5203 elsif Nkind
(Pref
) = N_Indexed_Component
then
5204 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
5206 -- For a record component, we can do Size in the front end if there
5207 -- is a component clause, or if the record is packed and the
5208 -- component's size is known at compile time.
5210 elsif Nkind
(Pref
) = N_Selected_Component
then
5212 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
5213 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5216 if Present
(Component_Clause
(Comp
)) then
5217 Siz
:= Esize
(Comp
);
5219 elsif Is_Packed
(Rec
) then
5220 Siz
:= RM_Size
(Ptyp
);
5223 Apply_Universal_Integer_Attribute_Checks
(N
);
5228 -- All other cases are handled by the back end
5231 Apply_Universal_Integer_Attribute_Checks
(N
);
5233 -- If Size is applied to a formal parameter that is of a packed
5234 -- array subtype, then apply Size to the actual subtype.
5236 if Is_Entity_Name
(Pref
)
5237 and then Is_Formal
(Entity
(Pref
))
5238 and then Is_Array_Type
(Ptyp
)
5239 and then Is_Packed
(Ptyp
)
5242 Make_Attribute_Reference
(Loc
,
5244 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
5245 Attribute_Name
=> Name_Size
));
5246 Analyze_And_Resolve
(N
, Typ
);
5249 -- If Size applies to a dereference of an access to unconstrained
5250 -- packed array, the back end needs to see its unconstrained
5251 -- nominal type, but also a hint to the actual constrained type.
5253 if Nkind
(Pref
) = N_Explicit_Dereference
5254 and then Is_Array_Type
(Ptyp
)
5255 and then not Is_Constrained
(Ptyp
)
5256 and then Is_Packed
(Ptyp
)
5258 Set_Actual_Designated_Subtype
(Pref
,
5259 Get_Actual_Subtype
(Pref
));
5265 -- Common processing for record and array component case
5267 if Siz
/= No_Uint
and then Siz
/= 0 then
5269 CS
: constant Boolean := Comes_From_Source
(N
);
5272 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
5274 -- This integer literal is not a static expression. We do not
5275 -- call Analyze_And_Resolve here, because this would activate
5276 -- the circuit for deciding that a static value was out of
5277 -- range, and we don't want that.
5279 -- So just manually set the type, mark the expression as non-
5280 -- static, and then ensure that the result is checked properly
5281 -- if the attribute comes from source (if it was internally
5282 -- generated, we never need a constraint check).
5285 Set_Is_Static_Expression
(N
, False);
5288 Apply_Constraint_Check
(N
, Typ
);
5298 when Attribute_Storage_Pool
=>
5300 Make_Type_Conversion
(Loc
,
5301 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
5302 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
5303 Analyze_And_Resolve
(N
, Typ
);
5309 when Attribute_Storage_Size
=> Storage_Size
: declare
5310 Alloc_Op
: Entity_Id
:= Empty
;
5314 -- Access type case, always go to the root type
5316 -- The case of access types results in a value of zero for the case
5317 -- where no storage size attribute clause has been given. If a
5318 -- storage size has been given, then the attribute is converted
5319 -- to a reference to the variable used to hold this value.
5321 if Is_Access_Type
(Ptyp
) then
5322 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
5324 Make_Attribute_Reference
(Loc
,
5325 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
5326 Attribute_Name
=> Name_Max
,
5327 Expressions
=> New_List
(
5328 Make_Integer_Literal
(Loc
, 0),
5331 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
5333 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
5335 -- If the access type is associated with a simple storage pool
5336 -- object, then attempt to locate the optional Storage_Size
5337 -- function of the simple storage pool type. If not found,
5338 -- then the result will default to zero.
5340 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
5341 Name_Simple_Storage_Pool_Type
))
5344 Pool_Type
: constant Entity_Id
:=
5345 Base_Type
(Etype
(Entity
(N
)));
5348 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
5349 while Present
(Alloc_Op
) loop
5350 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
5351 and then Present
(First_Formal
(Alloc_Op
))
5352 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
5357 Alloc_Op
:= Homonym
(Alloc_Op
);
5361 -- In the normal Storage_Pool case, retrieve the primitive
5362 -- function associated with the pool type.
5367 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
5368 Attribute_Name
(N
));
5371 -- If Storage_Size wasn't found (can only occur in the simple
5372 -- storage pool case), then simply use zero for the result.
5374 if not Present
(Alloc_Op
) then
5375 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5377 -- Otherwise, rewrite the allocator as a call to pool type's
5378 -- Storage_Size function.
5383 Make_Function_Call
(Loc
,
5385 New_Occurrence_Of
(Alloc_Op
, Loc
),
5387 Parameter_Associations
=> New_List
(
5389 (Associated_Storage_Pool
5390 (Root_Type
(Ptyp
)), Loc
)))));
5394 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5397 Analyze_And_Resolve
(N
, Typ
);
5399 -- For tasks, we retrieve the size directly from the TCB. The
5400 -- size may depend on a discriminant of the type, and therefore
5401 -- can be a per-object expression, so type-level information is
5402 -- not sufficient in general. There are four cases to consider:
5404 -- a) If the attribute appears within a task body, the designated
5405 -- TCB is obtained by a call to Self.
5407 -- b) If the prefix of the attribute is the name of a task object,
5408 -- the designated TCB is the one stored in the corresponding record.
5410 -- c) If the prefix is a task type, the size is obtained from the
5411 -- size variable created for each task type
5413 -- d) If no storage_size was specified for the type , there is no
5414 -- size variable, and the value is a system-specific default.
5417 if In_Open_Scopes
(Ptyp
) then
5419 -- Storage_Size (Self)
5423 Make_Function_Call
(Loc
,
5425 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5426 Parameter_Associations
=>
5428 Make_Function_Call
(Loc
,
5430 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
5432 elsif not Is_Entity_Name
(Pref
)
5433 or else not Is_Type
(Entity
(Pref
))
5435 -- Storage_Size (Rec (Obj).Size)
5439 Make_Function_Call
(Loc
,
5441 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5442 Parameter_Associations
=>
5444 Make_Selected_Component
(Loc
,
5446 Unchecked_Convert_To
(
5447 Corresponding_Record_Type
(Ptyp
),
5448 New_Copy_Tree
(Pref
)),
5450 Make_Identifier
(Loc
, Name_uTask_Id
))))));
5452 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
5454 -- Static storage size pragma given for type: retrieve value
5455 -- from its allocated storage variable.
5459 Make_Function_Call
(Loc
,
5460 Name
=> New_Occurrence_Of
(
5461 RTE
(RE_Adjust_Storage_Size
), Loc
),
5462 Parameter_Associations
=>
5465 Storage_Size_Variable
(Ptyp
), Loc
)))));
5467 -- Get system default
5471 Make_Function_Call
(Loc
,
5474 RTE
(RE_Default_Stack_Size
), Loc
))));
5477 Analyze_And_Resolve
(N
, Typ
);
5485 when Attribute_Stream_Size
=>
5487 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
5488 Analyze_And_Resolve
(N
, Typ
);
5494 -- 1. Deal with enumeration types with holes
5495 -- 2. For floating-point, generate call to attribute function
5496 -- 3. For other cases, deal with constraint checking
5498 when Attribute_Succ
=> Succ
: declare
5499 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5503 -- For enumeration types with non-standard representations, we
5504 -- expand typ'Succ (x) into
5506 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5508 -- If the representation is contiguous, we compute instead
5509 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5511 if Is_Enumeration_Type
(Ptyp
)
5512 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5514 if Has_Contiguous_Rep
(Etyp
) then
5516 Unchecked_Convert_To
(Ptyp
,
5519 Make_Integer_Literal
(Loc
,
5520 Enumeration_Rep
(First_Literal
(Ptyp
))),
5522 Make_Function_Call
(Loc
,
5525 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5527 Parameter_Associations
=>
5529 Unchecked_Convert_To
(Ptyp
,
5532 Unchecked_Convert_To
(Standard_Integer
,
5533 Relocate_Node
(First
(Exprs
))),
5535 Make_Integer_Literal
(Loc
, 1))),
5536 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5538 -- Add Boolean parameter True, to request program errror if
5539 -- we have a bad representation on our hands. Add False if
5540 -- checks are suppressed.
5542 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5544 Make_Indexed_Component
(Loc
,
5547 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5548 Expressions
=> New_List
(
5551 Make_Function_Call
(Loc
,
5554 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5555 Parameter_Associations
=> Exprs
),
5556 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5559 Analyze_And_Resolve
(N
, Typ
);
5561 -- For floating-point, we transform 'Succ into a call to the Succ
5562 -- floating-point attribute function in Fat_xxx (xxx is root type)
5564 elsif Is_Floating_Point_Type
(Ptyp
) then
5565 Expand_Fpt_Attribute_R
(N
);
5566 Analyze_And_Resolve
(N
, Typ
);
5568 -- For modular types, nothing to do (no overflow, since wraps)
5570 elsif Is_Modular_Integer_Type
(Ptyp
) then
5573 -- For other types, if argument is marked as needing a range check or
5574 -- overflow checking is enabled, we must generate a check.
5576 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5577 or else Do_Range_Check
(First
(Exprs
))
5579 Set_Do_Range_Check
(First
(Exprs
), False);
5580 Expand_Pred_Succ_Attribute
(N
);
5588 -- Transforms X'Tag into a direct reference to the tag of X
5590 when Attribute_Tag
=> Tag
: declare
5592 Prefix_Is_Type
: Boolean;
5595 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
5596 Ttyp
:= Entity
(Pref
);
5597 Prefix_Is_Type
:= True;
5600 Prefix_Is_Type
:= False;
5603 if Is_Class_Wide_Type
(Ttyp
) then
5604 Ttyp
:= Root_Type
(Ttyp
);
5607 Ttyp
:= Underlying_Type
(Ttyp
);
5609 -- Ada 2005: The type may be a synchronized tagged type, in which
5610 -- case the tag information is stored in the corresponding record.
5612 if Is_Concurrent_Type
(Ttyp
) then
5613 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
5616 if Prefix_Is_Type
then
5618 -- For VMs we leave the type attribute unexpanded because
5619 -- there's not a dispatching table to reference.
5621 if Tagged_Type_Expansion
then
5623 Unchecked_Convert_To
(RTE
(RE_Tag
),
5625 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
5626 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5629 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
5630 -- references the primary tag of the actual object. If 'Tag is
5631 -- applied to class-wide interface objects we generate code that
5632 -- displaces "this" to reference the base of the object.
5634 elsif Comes_From_Source
(N
)
5635 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
5636 and then Is_Interface
(Etype
(Prefix
(N
)))
5639 -- (To_Tag_Ptr (Prefix'Address)).all
5641 -- Note that Prefix'Address is recursively expanded into a call
5642 -- to Base_Address (Obj.Tag)
5644 -- Not needed for VM targets, since all handled by the VM
5646 if Tagged_Type_Expansion
then
5648 Make_Explicit_Dereference
(Loc
,
5649 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5650 Make_Attribute_Reference
(Loc
,
5651 Prefix
=> Relocate_Node
(Pref
),
5652 Attribute_Name
=> Name_Address
))));
5653 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5658 Make_Selected_Component
(Loc
,
5659 Prefix
=> Relocate_Node
(Pref
),
5661 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
5662 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5670 -- Transforms 'Terminated attribute into a call to Terminated function
5672 when Attribute_Terminated
=> Terminated
:
5674 -- The prefix of Terminated is of a task interface class-wide type.
5676 -- terminated (Task_Id (Pref._disp_get_task_id));
5678 if Ada_Version
>= Ada_2005
5679 and then Ekind
(Ptyp
) = E_Class_Wide_Type
5680 and then Is_Interface
(Ptyp
)
5681 and then Is_Task_Interface
(Ptyp
)
5684 Make_Function_Call
(Loc
,
5686 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
5687 Parameter_Associations
=> New_List
(
5688 Make_Unchecked_Type_Conversion
(Loc
,
5690 New_Occurrence_Of
(RTE
(RO_ST_Task_Id
), Loc
),
5692 Make_Selected_Component
(Loc
,
5694 New_Copy_Tree
(Pref
),
5696 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
5698 elsif Restricted_Profile
then
5700 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
5704 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
5707 Analyze_And_Resolve
(N
, Standard_Boolean
);
5714 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
5715 -- unchecked conversion from (integral) type of X to type address.
5717 when Attribute_To_Address | Attribute_Ref
=>
5719 Unchecked_Convert_To
(RTE
(RE_Address
),
5720 Relocate_Node
(First
(Exprs
))));
5721 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
5727 when Attribute_To_Any
=> To_Any
: declare
5728 P_Type
: constant Entity_Id
:= Etype
(Pref
);
5729 Decls
: constant List_Id
:= New_List
;
5735 Relocate_Node
(First
(Exprs
))), Decls
));
5736 Insert_Actions
(N
, Decls
);
5737 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
5744 -- Transforms 'Truncation into a call to the floating-point attribute
5745 -- function Truncation in Fat_xxx (where xxx is the root type).
5746 -- Expansion is avoided for cases the back end can handle directly.
5748 when Attribute_Truncation
=>
5749 if not Is_Inline_Floating_Point_Attribute
(N
) then
5750 Expand_Fpt_Attribute_R
(N
);
5757 when Attribute_TypeCode
=> TypeCode
: declare
5758 P_Type
: constant Entity_Id
:= Etype
(Pref
);
5759 Decls
: constant List_Id
:= New_List
;
5761 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
5762 Insert_Actions
(N
, Decls
);
5763 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
5766 -----------------------
5767 -- Unbiased_Rounding --
5768 -----------------------
5770 -- Transforms 'Unbiased_Rounding into a call to the floating-point
5771 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
5772 -- root type). Expansion is avoided for cases the back end can handle
5775 when Attribute_Unbiased_Rounding
=>
5776 if not Is_Inline_Floating_Point_Attribute
(N
) then
5777 Expand_Fpt_Attribute_R
(N
);
5784 when Attribute_UET_Address
=> UET_Address
: declare
5785 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5789 Make_Object_Declaration
(Loc
,
5790 Defining_Identifier
=> Ent
,
5791 Aliased_Present
=> True,
5792 Object_Definition
=>
5793 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5795 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
5796 -- in normal external form.
5798 Get_External_Unit_Name_String
(Get_Unit_Name
(Pref
));
5799 Name_Buffer
(1 + 7 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
5800 Name_Len
:= Name_Len
+ 7;
5801 Name_Buffer
(1 .. 7) := "__gnat_";
5802 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 5) := "__SDP";
5803 Name_Len
:= Name_Len
+ 5;
5805 Set_Is_Imported
(Ent
);
5806 Set_Interface_Name
(Ent
,
5807 Make_String_Literal
(Loc
,
5808 Strval
=> String_From_Name_Buffer
));
5810 -- Set entity as internal to ensure proper Sprint output of its
5811 -- implicit importation.
5813 Set_Is_Internal
(Ent
);
5816 Make_Attribute_Reference
(Loc
,
5817 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5818 Attribute_Name
=> Name_Address
));
5820 Analyze_And_Resolve
(N
, Typ
);
5827 when Attribute_Update
=>
5828 Expand_Update_Attribute
(N
);
5834 -- The processing for VADS_Size is shared with Size
5840 -- For enumeration types with a standard representation, and for all
5841 -- other types, Val is handled by the back end. For enumeration types
5842 -- with a non-standard representation we use the _Pos_To_Rep array that
5843 -- was created when the type was frozen.
5845 when Attribute_Val
=> Val
: declare
5846 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
5849 if Is_Enumeration_Type
(Etyp
)
5850 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5852 if Has_Contiguous_Rep
(Etyp
) then
5854 Rep_Node
: constant Node_Id
:=
5855 Unchecked_Convert_To
(Etyp
,
5858 Make_Integer_Literal
(Loc
,
5859 Enumeration_Rep
(First_Literal
(Etyp
))),
5861 (Convert_To
(Standard_Integer
,
5862 Relocate_Node
(First
(Exprs
))))));
5866 Unchecked_Convert_To
(Etyp
,
5869 Make_Integer_Literal
(Loc
,
5870 Enumeration_Rep
(First_Literal
(Etyp
))),
5872 Make_Function_Call
(Loc
,
5875 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5876 Parameter_Associations
=> New_List
(
5878 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
5883 Make_Indexed_Component
(Loc
,
5884 Prefix
=> New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
5885 Expressions
=> New_List
(
5886 Convert_To
(Standard_Integer
,
5887 Relocate_Node
(First
(Exprs
))))));
5890 Analyze_And_Resolve
(N
, Typ
);
5892 -- If the argument is marked as requiring a range check then generate
5895 elsif Do_Range_Check
(First
(Exprs
)) then
5896 Set_Do_Range_Check
(First
(Exprs
), False);
5897 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
5905 -- The code for valid is dependent on the particular types involved.
5906 -- See separate sections below for the generated code in each case.
5908 when Attribute_Valid
=> Valid
: declare
5909 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
5912 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
5913 -- Save the validity checking mode. We always turn off validity
5914 -- checking during process of 'Valid since this is one place
5915 -- where we do not want the implicit validity checks to intefere
5916 -- with the explicit validity check that the programmer is doing.
5918 function Make_Range_Test
return Node_Id
;
5919 -- Build the code for a range test of the form
5920 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
5922 ---------------------
5923 -- Make_Range_Test --
5924 ---------------------
5926 function Make_Range_Test
return Node_Id
is
5927 Temp
: constant Node_Id
:= Duplicate_Subexpr
(Pref
);
5930 -- The value whose validity is being checked has been captured in
5931 -- an object declaration. We certainly don't want this object to
5932 -- appear valid because the declaration initializes it.
5934 if Is_Entity_Name
(Temp
) then
5935 Set_Is_Known_Valid
(Entity
(Temp
), False);
5941 Unchecked_Convert_To
(Btyp
, Temp
),
5945 Unchecked_Convert_To
(Btyp
,
5946 Make_Attribute_Reference
(Loc
,
5947 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5948 Attribute_Name
=> Name_First
)),
5950 Unchecked_Convert_To
(Btyp
,
5951 Make_Attribute_Reference
(Loc
,
5952 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5953 Attribute_Name
=> Name_Last
))));
5954 end Make_Range_Test
;
5956 -- Start of processing for Attribute_Valid
5959 -- Do not expand sourced code 'Valid reference in CodePeer mode,
5960 -- will be handled by the back-end directly.
5962 if CodePeer_Mode
and then Comes_From_Source
(N
) then
5966 -- Turn off validity checks. We do not want any implicit validity
5967 -- checks to intefere with the explicit check from the attribute
5969 Validity_Checks_On
:= False;
5971 -- Retrieve the base type. Handle the case where the base type is a
5972 -- private enumeration type.
5974 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5975 Btyp
:= Full_View
(Btyp
);
5978 -- Floating-point case. This case is handled by the Valid attribute
5979 -- code in the floating-point attribute run-time library.
5981 if Is_Floating_Point_Type
(Ptyp
) then
5987 case Float_Rep
(Btyp
) is
5989 -- For vax fpt types, call appropriate routine in special
5990 -- vax floating point unit. No need to worry about loads in
5991 -- this case, since these types have no signalling NaN's.
5993 when VAX_Native
=> Expand_Vax_Valid
(N
);
5995 -- The AAMP back end handles Valid for floating-point types
5998 Analyze_And_Resolve
(Pref
, Ptyp
);
5999 Set_Etype
(N
, Standard_Boolean
);
6003 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
6005 -- If the floating-point object might be unaligned, we
6006 -- need to call the special routine Unaligned_Valid,
6007 -- which makes the needed copy, being careful not to
6008 -- load the value into any floating-point register.
6009 -- The argument in this case is obj'Address (see
6010 -- Unaligned_Valid routine in Fat_Gen).
6012 if Is_Possibly_Unaligned_Object
(Pref
) then
6013 Expand_Fpt_Attribute
6014 (N
, Pkg
, Name_Unaligned_Valid
,
6016 Make_Attribute_Reference
(Loc
,
6017 Prefix
=> Relocate_Node
(Pref
),
6018 Attribute_Name
=> Name_Address
)));
6020 -- In the normal case where we are sure the object is
6021 -- aligned, we generate a call to Valid, and the argument
6022 -- in this case is obj'Unrestricted_Access (after
6023 -- converting obj to the right floating-point type).
6026 Expand_Fpt_Attribute
6027 (N
, Pkg
, Name_Valid
,
6029 Make_Attribute_Reference
(Loc
,
6030 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
6031 Attribute_Name
=> Name_Unrestricted_Access
)));
6035 -- One more task, we still need a range check. Required
6036 -- only if we have a constraint, since the Valid routine
6037 -- catches infinities properly (infinities are never valid).
6039 -- The way we do the range check is simply to create the
6040 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6042 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
6045 Left_Opnd
=> Relocate_Node
(N
),
6048 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
6049 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
6053 -- Enumeration type with holes
6055 -- For enumeration types with holes, the Pos value constructed by
6056 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6057 -- second argument of False returns minus one for an invalid value,
6058 -- and the non-negative pos value for a valid value, so the
6059 -- expansion of X'Valid is simply:
6061 -- type(X)'Pos (X) >= 0
6063 -- We can't quite generate it that way because of the requirement
6064 -- for the non-standard second argument of False in the resulting
6065 -- rep_to_pos call, so we have to explicitly create:
6067 -- _rep_to_pos (X, False) >= 0
6069 -- If we have an enumeration subtype, we also check that the
6070 -- value is in range:
6072 -- _rep_to_pos (X, False) >= 0
6074 -- (X >= type(X)'First and then type(X)'Last <= X)
6076 elsif Is_Enumeration_Type
(Ptyp
)
6077 and then Present
(Enum_Pos_To_Rep
(Btyp
))
6082 Make_Function_Call
(Loc
,
6084 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
6085 Parameter_Associations
=> New_List
(
6087 New_Occurrence_Of
(Standard_False
, Loc
))),
6088 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
6092 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
6094 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
6096 -- The call to Make_Range_Test will create declarations
6097 -- that need a proper insertion point, but Pref is now
6098 -- attached to a node with no ancestor. Attach to tree
6099 -- even if it is to be rewritten below.
6101 Set_Parent
(Tst
, Parent
(N
));
6105 Left_Opnd
=> Make_Range_Test
,
6111 -- Fortran convention booleans
6113 -- For the very special case of Fortran convention booleans, the
6114 -- value is always valid, since it is an integer with the semantics
6115 -- that non-zero is true, and any value is permissible.
6117 elsif Is_Boolean_Type
(Ptyp
)
6118 and then Convention
(Ptyp
) = Convention_Fortran
6120 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
6122 -- For biased representations, we will be doing an unchecked
6123 -- conversion without unbiasing the result. That means that the range
6124 -- test has to take this into account, and the proper form of the
6127 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6129 elsif Has_Biased_Representation
(Ptyp
) then
6130 Btyp
:= RTE
(RE_Unsigned_32
);
6134 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
6136 Unchecked_Convert_To
(Btyp
,
6137 Make_Attribute_Reference
(Loc
,
6138 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6139 Attribute_Name
=> Name_Range_Length
))));
6141 -- For all other scalar types, what we want logically is a
6144 -- X in type(X)'First .. type(X)'Last
6146 -- But that's precisely what won't work because of possible
6147 -- unwanted optimization (and indeed the basic motivation for
6148 -- the Valid attribute is exactly that this test does not work).
6149 -- What will work is:
6151 -- Btyp!(X) >= Btyp!(type(X)'First)
6153 -- Btyp!(X) <= Btyp!(type(X)'Last)
6155 -- where Btyp is an integer type large enough to cover the full
6156 -- range of possible stored values (i.e. it is chosen on the basis
6157 -- of the size of the type, not the range of the values). We write
6158 -- this as two tests, rather than a range check, so that static
6159 -- evaluation will easily remove either or both of the checks if
6160 -- they can be -statically determined to be true (this happens
6161 -- when the type of X is static and the range extends to the full
6162 -- range of stored values).
6164 -- Unsigned types. Note: it is safe to consider only whether the
6165 -- subtype is unsigned, since we will in that case be doing all
6166 -- unsigned comparisons based on the subtype range. Since we use the
6167 -- actual subtype object size, this is appropriate.
6169 -- For example, if we have
6171 -- subtype x is integer range 1 .. 200;
6172 -- for x'Object_Size use 8;
6174 -- Now the base type is signed, but objects of this type are bits
6175 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6176 -- correct, even though a value greater than 127 looks signed to a
6177 -- signed comparison.
6179 elsif Is_Unsigned_Type
(Ptyp
) then
6180 if Esize
(Ptyp
) <= 32 then
6181 Btyp
:= RTE
(RE_Unsigned_32
);
6183 Btyp
:= RTE
(RE_Unsigned_64
);
6186 Rewrite
(N
, Make_Range_Test
);
6191 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6192 Btyp
:= Standard_Integer
;
6194 Btyp
:= Universal_Integer
;
6197 Rewrite
(N
, Make_Range_Test
);
6200 -- If a predicate is present, then we do the predicate test, even if
6201 -- within the predicate function (infinite recursion is warned about
6202 -- in Sem_Attr in that case).
6205 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6208 if Present
(Pred_Func
) then
6211 Left_Opnd
=> Relocate_Node
(N
),
6212 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6216 Analyze_And_Resolve
(N
, Standard_Boolean
);
6217 Validity_Checks_On
:= Save_Validity_Checks_On
;
6224 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6228 if Present
(Underlying_Type
(Ptyp
)) then
6229 Ftyp
:= Underlying_Type
(Ptyp
);
6234 -- For scalar types, Valid_Scalars is the same as Valid
6236 if Is_Scalar_Type
(Ftyp
) then
6238 Make_Attribute_Reference
(Loc
,
6239 Attribute_Name
=> Name_Valid
,
6241 Analyze_And_Resolve
(N
, Standard_Boolean
);
6243 -- For array types, we construct a function that determines if there
6244 -- are any non-valid scalar subcomponents, and call the function.
6245 -- We only do this for arrays whose component type needs checking
6247 elsif Is_Array_Type
(Ftyp
)
6248 and then not No_Scalar_Parts
(Component_Type
(Ftyp
))
6251 Make_Function_Call
(Loc
,
6253 New_Occurrence_Of
(Build_Array_VS_Func
(Ftyp
, N
), Loc
),
6254 Parameter_Associations
=> New_List
(Pref
)));
6256 Analyze_And_Resolve
(N
, Standard_Boolean
);
6258 -- For record types, we build a big if expression, applying Valid or
6259 -- Valid_Scalars as appropriate to all relevant components.
6261 elsif (Is_Record_Type
(Ptyp
) or else Has_Discriminants
(Ptyp
))
6262 and then not No_Scalar_Parts
(Ptyp
)
6270 X
:= New_Occurrence_Of
(Standard_True
, Loc
);
6271 C
:= First_Component_Or_Discriminant
(Ptyp
);
6272 while Present
(C
) loop
6273 if No_Scalar_Parts
(Etype
(C
)) then
6275 elsif Is_Scalar_Type
(Etype
(C
)) then
6278 A
:= Name_Valid_Scalars
;
6285 Make_Attribute_Reference
(Loc
,
6286 Attribute_Name
=> A
,
6288 Make_Selected_Component
(Loc
,
6290 Duplicate_Subexpr
(Pref
, Name_Req
=> True),
6292 New_Occurrence_Of
(C
, Loc
))));
6294 Next_Component_Or_Discriminant
(C
);
6298 Analyze_And_Resolve
(N
, Standard_Boolean
);
6301 -- For all other types, result is True (but not static)
6304 Rewrite
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
6305 Analyze_And_Resolve
(N
, Standard_Boolean
);
6306 Set_Is_Static_Expression
(N
, False);
6314 -- Value attribute is handled in separate unit Exp_Imgv
6316 when Attribute_Value
=>
6317 Exp_Imgv
.Expand_Value_Attribute
(N
);
6323 -- The processing for Value_Size shares the processing for Size
6329 -- The processing for Version shares the processing for Body_Version
6335 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6337 when Attribute_Wide_Image
=>
6338 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
6340 ---------------------
6341 -- Wide_Wide_Image --
6342 ---------------------
6344 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6346 when Attribute_Wide_Wide_Image
=>
6347 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
6353 -- We expand typ'Wide_Value (X) into
6356 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6358 -- Wide_String_To_String is a runtime function that converts its wide
6359 -- string argument to String, converting any non-translatable characters
6360 -- into appropriate escape sequences. This preserves the required
6361 -- semantics of Wide_Value in all cases, and results in a very simple
6362 -- implementation approach.
6364 -- Note: for this approach to be fully standard compliant for the cases
6365 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6366 -- method must cover the entire character range (e.g. UTF-8). But that
6367 -- is a reasonable requirement when dealing with encoded character
6368 -- sequences. Presumably if one of the restrictive encoding mechanisms
6369 -- is in use such as Shift-JIS, then characters that cannot be
6370 -- represented using this encoding will not appear in any case.
6372 when Attribute_Wide_Value
=> Wide_Value
:
6375 Make_Attribute_Reference
(Loc
,
6377 Attribute_Name
=> Name_Value
,
6379 Expressions
=> New_List
(
6380 Make_Function_Call
(Loc
,
6382 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
6384 Parameter_Associations
=> New_List
(
6385 Relocate_Node
(First
(Exprs
)),
6386 Make_Integer_Literal
(Loc
,
6387 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6389 Analyze_And_Resolve
(N
, Typ
);
6392 ---------------------
6393 -- Wide_Wide_Value --
6394 ---------------------
6396 -- We expand typ'Wide_Value_Value (X) into
6399 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6401 -- Wide_Wide_String_To_String is a runtime function that converts its
6402 -- wide string argument to String, converting any non-translatable
6403 -- characters into appropriate escape sequences. This preserves the
6404 -- required semantics of Wide_Wide_Value in all cases, and results in a
6405 -- very simple implementation approach.
6407 -- It's not quite right where typ = Wide_Wide_Character, because the
6408 -- encoding method may not cover the whole character type ???
6410 when Attribute_Wide_Wide_Value
=> Wide_Wide_Value
:
6413 Make_Attribute_Reference
(Loc
,
6415 Attribute_Name
=> Name_Value
,
6417 Expressions
=> New_List
(
6418 Make_Function_Call
(Loc
,
6421 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
6423 Parameter_Associations
=> New_List
(
6424 Relocate_Node
(First
(Exprs
)),
6425 Make_Integer_Literal
(Loc
,
6426 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6428 Analyze_And_Resolve
(N
, Typ
);
6429 end Wide_Wide_Value
;
6431 ---------------------
6432 -- Wide_Wide_Width --
6433 ---------------------
6435 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6437 when Attribute_Wide_Wide_Width
=>
6438 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
6444 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6446 when Attribute_Wide_Width
=>
6447 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
6453 -- Width attribute is handled in separate unit Exp_Imgv
6455 when Attribute_Width
=>
6456 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
6462 when Attribute_Write
=> Write
: declare
6463 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6464 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6472 -- If no underlying type, we have an error that will be diagnosed
6473 -- elsewhere, so here we just completely ignore the expansion.
6479 -- The simple case, if there is a TSS for Write, just call it
6481 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
6483 if Present
(Pname
) then
6487 -- If there is a Stream_Convert pragma, use it, we rewrite
6489 -- sourcetyp'Output (stream, Item)
6493 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6495 -- where strmwrite is the given Write function that converts an
6496 -- argument of type sourcetyp or a type acctyp, from which it is
6497 -- derived to type strmtyp. The conversion to acttyp is required
6498 -- for the derived case.
6500 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6502 if Present
(Prag
) then
6504 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
6505 Wfunc
:= Entity
(Expression
(Arg3
));
6508 Make_Attribute_Reference
(Loc
,
6509 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
6510 Attribute_Name
=> Name_Output
,
6511 Expressions
=> New_List
(
6512 Relocate_Node
(First
(Exprs
)),
6513 Make_Function_Call
(Loc
,
6514 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
6515 Parameter_Associations
=> New_List
(
6516 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
6517 Relocate_Node
(Next
(First
(Exprs
)))))))));
6522 -- For elementary types, we call the W_xxx routine directly
6524 elsif Is_Elementary_Type
(U_Type
) then
6525 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
6531 elsif Is_Array_Type
(U_Type
) then
6532 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
6533 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
6535 -- Tagged type case, use the primitive Write function. Note that
6536 -- this will dispatch in the class-wide case which is what we want
6538 elsif Is_Tagged_Type
(U_Type
) then
6539 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
6541 -- All other record type cases, including protected records.
6542 -- The latter only arise for expander generated code for
6543 -- handling shared passive partition access.
6547 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
6549 -- Ada 2005 (AI-216): Program_Error is raised when executing
6550 -- the default implementation of the Write attribute of an
6551 -- Unchecked_Union type. However, if the 'Write reference is
6552 -- within the generated Output stream procedure, Write outputs
6553 -- the components, and the default values of the discriminant
6554 -- are streamed by the Output procedure itself.
6556 if Is_Unchecked_Union
(Base_Type
(U_Type
))
6557 and not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
6560 Make_Raise_Program_Error
(Loc
,
6561 Reason
=> PE_Unchecked_Union_Restriction
));
6564 if Has_Discriminants
(U_Type
)
6566 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
6568 Build_Mutable_Record_Write_Procedure
6569 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6571 Build_Record_Write_Procedure
6572 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6575 Insert_Action
(N
, Decl
);
6579 -- If we fall through, Pname is the procedure to be called
6581 Rewrite_Stream_Proc_Call
(Pname
);
6584 -- Component_Size is handled by the back end, unless the component size
6585 -- is known at compile time, which is always true in the packed array
6586 -- case. It is important that the packed array case is handled in the
6587 -- front end (see Eval_Attribute) since the back end would otherwise get
6588 -- confused by the equivalent packed array type.
6590 when Attribute_Component_Size
=>
6593 -- The following attributes are handled by the back end (except that
6594 -- static cases have already been evaluated during semantic processing,
6595 -- but in any case the back end should not count on this).
6597 -- The back end also handles the non-class-wide cases of Size
6599 when Attribute_Bit_Order |
6600 Attribute_Code_Address |
6601 Attribute_Definite |
6602 Attribute_Null_Parameter |
6603 Attribute_Passed_By_Reference |
6604 Attribute_Pool_Address |
6605 Attribute_Scalar_Storage_Order
=>
6608 -- The following attributes are also handled by the back end, but return
6609 -- a universal integer result, so may need a conversion for checking
6610 -- that the result is in range.
6612 when Attribute_Aft |
6613 Attribute_Max_Alignment_For_Allocation
=>
6614 Apply_Universal_Integer_Attribute_Checks
(N
);
6616 -- The following attributes should not appear at this stage, since they
6617 -- have already been handled by the analyzer (and properly rewritten
6618 -- with corresponding values or entities to represent the right values)
6620 when Attribute_Abort_Signal |
6621 Attribute_Address_Size |
6622 Attribute_Atomic_Always_Lock_Free |
6625 Attribute_Compiler_Version |
6626 Attribute_Default_Bit_Order |
6633 Attribute_Fast_Math |
6634 Attribute_First_Valid |
6635 Attribute_Has_Access_Values |
6636 Attribute_Has_Discriminants |
6637 Attribute_Has_Tagged_Values |
6639 Attribute_Last_Valid |
6640 Attribute_Library_Level |
6641 Attribute_Lock_Free |
6642 Attribute_Machine_Emax |
6643 Attribute_Machine_Emin |
6644 Attribute_Machine_Mantissa |
6645 Attribute_Machine_Overflows |
6646 Attribute_Machine_Radix |
6647 Attribute_Machine_Rounds |
6648 Attribute_Maximum_Alignment |
6649 Attribute_Model_Emin |
6650 Attribute_Model_Epsilon |
6651 Attribute_Model_Mantissa |
6652 Attribute_Model_Small |
6654 Attribute_Partition_ID |
6656 Attribute_Restriction_Set |
6657 Attribute_Safe_Emax |
6658 Attribute_Safe_First |
6659 Attribute_Safe_Large |
6660 Attribute_Safe_Last |
6661 Attribute_Safe_Small |
6663 Attribute_Signed_Zeros |
6665 Attribute_Storage_Unit |
6666 Attribute_Stub_Type |
6667 Attribute_System_Allocator_Alignment |
6668 Attribute_Target_Name |
6669 Attribute_Type_Class |
6670 Attribute_Type_Key |
6671 Attribute_Unconstrained_Array |
6672 Attribute_Universal_Literal_String |
6673 Attribute_Wchar_T_Size |
6674 Attribute_Word_Size
=>
6675 raise Program_Error
;
6677 -- The Asm_Input and Asm_Output attributes are not expanded at this
6678 -- stage, but will be eliminated in the expansion of the Asm call, see
6679 -- Exp_Intr for details. So the back end will never see these either.
6681 when Attribute_Asm_Input |
6682 Attribute_Asm_Output
=>
6686 -- Note: as mentioned earlier, individual sections of the above case
6687 -- statement assume there is no code after the case statement, and are
6688 -- legitimately allowed to execute return statements if they have nothing
6689 -- more to do, so DO NOT add code at this point.
6692 when RE_Not_Available
=>
6694 end Expand_N_Attribute_Reference
;
6696 --------------------------------
6697 -- Expand_Pred_Succ_Attribute --
6698 --------------------------------
6700 -- For typ'Pred (exp), we generate the check
6702 -- [constraint_error when exp = typ'Base'First]
6704 -- Similarly, for typ'Succ (exp), we generate the check
6706 -- [constraint_error when exp = typ'Base'Last]
6708 -- These checks are not generated for modular types, since the proper
6709 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
6710 -- We also suppress these checks if we are the right side of an assignment
6711 -- statement or the expression of an object declaration, where the flag
6712 -- Suppress_Assignment_Checks is set for the assignment/declaration.
6714 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
6715 Loc
: constant Source_Ptr
:= Sloc
(N
);
6716 P
: constant Node_Id
:= Parent
(N
);
6720 if Attribute_Name
(N
) = Name_Pred
then
6726 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
6727 or else not Suppress_Assignment_Checks
(P
)
6730 Make_Raise_Constraint_Error
(Loc
,
6734 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
6736 Make_Attribute_Reference
(Loc
,
6738 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
6739 Attribute_Name
=> Cnam
)),
6740 Reason
=> CE_Overflow_Check_Failed
));
6742 end Expand_Pred_Succ_Attribute
;
6744 -----------------------------
6745 -- Expand_Update_Attribute --
6746 -----------------------------
6748 procedure Expand_Update_Attribute
(N
: Node_Id
) is
6749 procedure Process_Component_Or_Element_Update
6754 -- Generate the statements necessary to update a single component or an
6755 -- element of the prefix. The code is inserted before the attribute N.
6756 -- Temp denotes the entity of the anonymous object created to reflect
6757 -- the changes in values. Comp is the component/index expression to be
6758 -- updated. Expr is an expression yielding the new value of Comp. Typ
6759 -- is the type of the prefix of attribute Update.
6761 procedure Process_Range_Update
6766 -- Generate the statements necessary to update a slice of the prefix.
6767 -- The code is inserted before the attribute N. Temp denotes the entity
6768 -- of the anonymous object created to reflect the changes in values.
6769 -- Comp is range of the slice to be updated. Expr is an expression
6770 -- yielding the new value of Comp. Typ is the type of the prefix of
6771 -- attribute Update.
6773 -----------------------------------------
6774 -- Process_Component_Or_Element_Update --
6775 -----------------------------------------
6777 procedure Process_Component_Or_Element_Update
6783 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
6788 -- An array element may be modified by the following relations
6789 -- depending on the number of dimensions:
6791 -- 1 => Expr -- one dimensional update
6792 -- (1, ..., N) => Expr -- multi dimensional update
6794 -- The above forms are converted in assignment statements where the
6795 -- left hand side is an indexed component:
6797 -- Temp (1) := Expr; -- one dimensional update
6798 -- Temp (1, ..., N) := Expr; -- multi dimensional update
6800 if Is_Array_Type
(Typ
) then
6802 -- The index expressions of a multi dimensional array update
6803 -- appear as an aggregate.
6805 if Nkind
(Comp
) = N_Aggregate
then
6806 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
6808 Exprs
:= New_List
(Relocate_Node
(Comp
));
6812 Make_Indexed_Component
(Loc
,
6813 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
6814 Expressions
=> Exprs
);
6816 -- A record component update appears in the following form:
6820 -- The above relation is transformed into an assignment statement
6821 -- where the left hand side is a selected component:
6823 -- Temp.Comp := Expr;
6825 else pragma Assert
(Is_Record_Type
(Typ
));
6827 Make_Selected_Component
(Loc
,
6828 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
6829 Selector_Name
=> Relocate_Node
(Comp
));
6833 Make_Assignment_Statement
(Loc
,
6835 Expression
=> Relocate_Node
(Expr
)));
6836 end Process_Component_Or_Element_Update
;
6838 --------------------------
6839 -- Process_Range_Update --
6840 --------------------------
6842 procedure Process_Range_Update
6848 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
6849 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
6853 -- A range update appears as
6855 -- (Low .. High => Expr)
6857 -- The above construct is transformed into a loop that iterates over
6858 -- the given range and modifies the corresponding array values to the
6861 -- for Index in Low .. High loop
6862 -- Temp (<Index_Typ> (Index)) := Expr;
6865 Index
:= Make_Temporary
(Loc
, 'I');
6868 Make_Loop_Statement
(Loc
,
6870 Make_Iteration_Scheme
(Loc
,
6871 Loop_Parameter_Specification
=>
6872 Make_Loop_Parameter_Specification
(Loc
,
6873 Defining_Identifier
=> Index
,
6874 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
6876 Statements
=> New_List
(
6877 Make_Assignment_Statement
(Loc
,
6879 Make_Indexed_Component
(Loc
,
6880 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
6881 Expressions
=> New_List
(
6882 Convert_To
(Index_Typ
,
6883 New_Occurrence_Of
(Index
, Loc
)))),
6884 Expression
=> Relocate_Node
(Expr
))),
6886 End_Label
=> Empty
));
6887 end Process_Range_Update
;
6891 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
6892 Loc
: constant Source_Ptr
:= Sloc
(N
);
6893 Pref
: constant Node_Id
:= Prefix
(N
);
6894 Typ
: constant Entity_Id
:= Etype
(Pref
);
6900 -- Start of processing for Expand_Update_Attribute
6903 -- Create the anonymous object that stores the value of the prefix and
6904 -- reflects subsequent changes in value. Generate:
6906 -- Temp : <type of Pref> := Pref;
6908 Temp
:= Make_Temporary
(Loc
, 'T');
6911 Make_Object_Declaration
(Loc
,
6912 Defining_Identifier
=> Temp
,
6913 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
6914 Expression
=> Relocate_Node
(Pref
)));
6916 -- Process the update aggregate
6918 Assoc
:= First
(Component_Associations
(Aggr
));
6919 while Present
(Assoc
) loop
6920 Comp
:= First
(Choices
(Assoc
));
6921 Expr
:= Expression
(Assoc
);
6922 while Present
(Comp
) loop
6923 if Nkind
(Comp
) = N_Range
then
6924 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
6926 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
6935 -- The attribute is replaced by a reference to the anonymous object
6937 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
6939 end Expand_Update_Attribute
;
6945 procedure Find_Fat_Info
6947 Fat_Type
: out Entity_Id
;
6948 Fat_Pkg
: out RE_Id
)
6950 Btyp
: constant Entity_Id
:= Base_Type
(T
);
6951 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
6952 Digs
: constant Nat
:= UI_To_Int
(Digits_Value
(Btyp
));
6955 -- If the base type is VAX float, then get appropriate VAX float type
6957 if Vax_Float
(Btyp
) then
6960 Fat_Type
:= RTE
(RE_Fat_VAX_F
);
6961 Fat_Pkg
:= RE_Attr_VAX_F_Float
;
6964 Fat_Type
:= RTE
(RE_Fat_VAX_D
);
6965 Fat_Pkg
:= RE_Attr_VAX_D_Float
;
6968 Fat_Type
:= RTE
(RE_Fat_VAX_G
);
6969 Fat_Pkg
:= RE_Attr_VAX_G_Float
;
6972 raise Program_Error
;
6975 -- If root type is VAX float, this is the case where the library has
6976 -- been recompiled in VAX float mode, and we have an IEEE float type.
6977 -- This is when we use the special IEEE Fat packages.
6979 elsif Vax_Float
(Rtyp
) then
6982 Fat_Type
:= RTE
(RE_Fat_IEEE_Short
);
6983 Fat_Pkg
:= RE_Attr_IEEE_Short
;
6986 Fat_Type
:= RTE
(RE_Fat_IEEE_Long
);
6987 Fat_Pkg
:= RE_Attr_IEEE_Long
;
6990 raise Program_Error
;
6993 -- If neither the base type nor the root type is VAX_Native then VAX
6994 -- float is out of the picture, and we can just use the root type.
6999 if Fat_Type
= Standard_Short_Float
then
7000 Fat_Pkg
:= RE_Attr_Short_Float
;
7002 elsif Fat_Type
= Standard_Float
then
7003 Fat_Pkg
:= RE_Attr_Float
;
7005 elsif Fat_Type
= Standard_Long_Float
then
7006 Fat_Pkg
:= RE_Attr_Long_Float
;
7008 elsif Fat_Type
= Standard_Long_Long_Float
then
7009 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7011 -- Universal real (which is its own root type) is treated as being
7012 -- equivalent to Standard.Long_Long_Float, since it is defined to
7013 -- have the same precision as the longest Float type.
7015 elsif Fat_Type
= Universal_Real
then
7016 Fat_Type
:= Standard_Long_Long_Float
;
7017 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
7020 raise Program_Error
;
7025 ----------------------------
7026 -- Find_Stream_Subprogram --
7027 ----------------------------
7029 function Find_Stream_Subprogram
7031 Nam
: TSS_Name_Type
) return Entity_Id
7033 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
7034 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
7036 function Is_Available
(Entity
: RE_Id
) return Boolean;
7037 pragma Inline
(Is_Available
);
7038 -- Function to check whether the specified run-time call is available
7039 -- in the run time used. In the case of a configurable run time, it
7040 -- is normal that some subprograms are not there.
7042 -- I don't understand this routine at all, why is this not just a
7043 -- call to RTE_Available? And if for some reason we need a different
7044 -- routine with different semantics, why is not in Rtsfind ???
7050 function Is_Available
(Entity
: RE_Id
) return Boolean is
7052 -- Assume that the unit will always be available when using a
7053 -- "normal" (not configurable) run time.
7055 return not Configurable_Run_Time_Mode
or else RTE_Available
(Entity
);
7058 -- Start of processing for Find_Stream_Subprogram
7061 if Present
(Ent
) then
7065 -- Stream attributes for strings are expanded into library calls. The
7066 -- following checks are disabled when the run-time is not available or
7067 -- when compiling predefined types due to bootstrap issues. As a result,
7068 -- the compiler will generate in-place stream routines for string types
7069 -- that appear in GNAT's library, but will generate calls via rtsfind
7070 -- to library routines for user code.
7072 -- ??? For now, disable this code for JVM, since this generates a
7073 -- VerifyError exception at run time on e.g. c330001.
7075 -- This is disabled for AAMP, to avoid creating dependences on files not
7076 -- supported in the AAMP library (such as s-fileio.adb).
7078 -- Note: In the case of using a configurable run time, it is very likely
7079 -- that stream routines for string types are not present (they require
7080 -- file system support). In this case, the specific stream routines for
7081 -- strings are not used, relying on the regular stream mechanism
7082 -- instead. That is why we include the test Is_Available when dealing
7083 -- with these cases.
7085 if VM_Target
/= JVM_Target
7086 and then not AAMP_On_Target
7088 not Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
7090 -- Storage_Array as defined in package System.Storage_Elements
7092 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
7094 -- Case of No_Stream_Optimizations restriction active
7096 if Restriction_Active
(No_Stream_Optimizations
) then
7097 if Nam
= TSS_Stream_Input
7098 and then Is_Available
(RE_Storage_Array_Input
)
7100 return RTE
(RE_Storage_Array_Input
);
7102 elsif Nam
= TSS_Stream_Output
7103 and then Is_Available
(RE_Storage_Array_Output
)
7105 return RTE
(RE_Storage_Array_Output
);
7107 elsif Nam
= TSS_Stream_Read
7108 and then Is_Available
(RE_Storage_Array_Read
)
7110 return RTE
(RE_Storage_Array_Read
);
7112 elsif Nam
= TSS_Stream_Write
7113 and then Is_Available
(RE_Storage_Array_Write
)
7115 return RTE
(RE_Storage_Array_Write
);
7117 elsif Nam
/= TSS_Stream_Input
and then
7118 Nam
/= TSS_Stream_Output
and then
7119 Nam
/= TSS_Stream_Read
and then
7120 Nam
/= TSS_Stream_Write
7122 raise Program_Error
;
7125 -- Restriction No_Stream_Optimizations is not set, so we can go
7126 -- ahead and optimize using the block IO forms of the routines.
7129 if Nam
= TSS_Stream_Input
7130 and then Is_Available
(RE_Storage_Array_Input_Blk_IO
)
7132 return RTE
(RE_Storage_Array_Input_Blk_IO
);
7134 elsif Nam
= TSS_Stream_Output
7135 and then Is_Available
(RE_Storage_Array_Output_Blk_IO
)
7137 return RTE
(RE_Storage_Array_Output_Blk_IO
);
7139 elsif Nam
= TSS_Stream_Read
7140 and then Is_Available
(RE_Storage_Array_Read_Blk_IO
)
7142 return RTE
(RE_Storage_Array_Read_Blk_IO
);
7144 elsif Nam
= TSS_Stream_Write
7145 and then Is_Available
(RE_Storage_Array_Write_Blk_IO
)
7147 return RTE
(RE_Storage_Array_Write_Blk_IO
);
7149 elsif Nam
/= TSS_Stream_Input
and then
7150 Nam
/= TSS_Stream_Output
and then
7151 Nam
/= TSS_Stream_Read
and then
7152 Nam
/= TSS_Stream_Write
7154 raise Program_Error
;
7158 -- Stream_Element_Array as defined in package Ada.Streams
7160 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
7162 -- Case of No_Stream_Optimizations restriction active
7164 if Restriction_Active
(No_Stream_Optimizations
) then
7165 if Nam
= TSS_Stream_Input
7166 and then Is_Available
(RE_Stream_Element_Array_Input
)
7168 return RTE
(RE_Stream_Element_Array_Input
);
7170 elsif Nam
= TSS_Stream_Output
7171 and then Is_Available
(RE_Stream_Element_Array_Output
)
7173 return RTE
(RE_Stream_Element_Array_Output
);
7175 elsif Nam
= TSS_Stream_Read
7176 and then Is_Available
(RE_Stream_Element_Array_Read
)
7178 return RTE
(RE_Stream_Element_Array_Read
);
7180 elsif Nam
= TSS_Stream_Write
7181 and then Is_Available
(RE_Stream_Element_Array_Write
)
7183 return RTE
(RE_Stream_Element_Array_Write
);
7185 elsif Nam
/= TSS_Stream_Input
and then
7186 Nam
/= TSS_Stream_Output
and then
7187 Nam
/= TSS_Stream_Read
and then
7188 Nam
/= TSS_Stream_Write
7190 raise Program_Error
;
7193 -- Restriction No_Stream_Optimizations is not set, so we can go
7194 -- ahead and optimize using the block IO forms of the routines.
7197 if Nam
= TSS_Stream_Input
7198 and then Is_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
7200 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
7202 elsif Nam
= TSS_Stream_Output
7203 and then Is_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
7205 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
7207 elsif Nam
= TSS_Stream_Read
7208 and then Is_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
7210 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
7212 elsif Nam
= TSS_Stream_Write
7213 and then Is_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
7215 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
7217 elsif Nam
/= TSS_Stream_Input
and then
7218 Nam
/= TSS_Stream_Output
and then
7219 Nam
/= TSS_Stream_Read
and then
7220 Nam
/= TSS_Stream_Write
7222 raise Program_Error
;
7226 -- String as defined in package Ada
7228 elsif Base_Typ
= Standard_String
then
7230 -- Case of No_Stream_Optimizations restriction active
7232 if Restriction_Active
(No_Stream_Optimizations
) then
7233 if Nam
= TSS_Stream_Input
7234 and then Is_Available
(RE_String_Input
)
7236 return RTE
(RE_String_Input
);
7238 elsif Nam
= TSS_Stream_Output
7239 and then Is_Available
(RE_String_Output
)
7241 return RTE
(RE_String_Output
);
7243 elsif Nam
= TSS_Stream_Read
7244 and then Is_Available
(RE_String_Read
)
7246 return RTE
(RE_String_Read
);
7248 elsif Nam
= TSS_Stream_Write
7249 and then Is_Available
(RE_String_Write
)
7251 return RTE
(RE_String_Write
);
7253 elsif Nam
/= TSS_Stream_Input
and then
7254 Nam
/= TSS_Stream_Output
and then
7255 Nam
/= TSS_Stream_Read
and then
7256 Nam
/= TSS_Stream_Write
7258 raise Program_Error
;
7261 -- Restriction No_Stream_Optimizations is not set, so we can go
7262 -- ahead and optimize using the block IO forms of the routines.
7265 if Nam
= TSS_Stream_Input
7266 and then Is_Available
(RE_String_Input_Blk_IO
)
7268 return RTE
(RE_String_Input_Blk_IO
);
7270 elsif Nam
= TSS_Stream_Output
7271 and then Is_Available
(RE_String_Output_Blk_IO
)
7273 return RTE
(RE_String_Output_Blk_IO
);
7275 elsif Nam
= TSS_Stream_Read
7276 and then Is_Available
(RE_String_Read_Blk_IO
)
7278 return RTE
(RE_String_Read_Blk_IO
);
7280 elsif Nam
= TSS_Stream_Write
7281 and then Is_Available
(RE_String_Write_Blk_IO
)
7283 return RTE
(RE_String_Write_Blk_IO
);
7285 elsif Nam
/= TSS_Stream_Input
and then
7286 Nam
/= TSS_Stream_Output
and then
7287 Nam
/= TSS_Stream_Read
and then
7288 Nam
/= TSS_Stream_Write
7290 raise Program_Error
;
7294 -- Wide_String as defined in package Ada
7296 elsif Base_Typ
= Standard_Wide_String
then
7298 -- Case of No_Stream_Optimizations restriction active
7300 if Restriction_Active
(No_Stream_Optimizations
) then
7301 if Nam
= TSS_Stream_Input
7302 and then Is_Available
(RE_Wide_String_Input
)
7304 return RTE
(RE_Wide_String_Input
);
7306 elsif Nam
= TSS_Stream_Output
7307 and then Is_Available
(RE_Wide_String_Output
)
7309 return RTE
(RE_Wide_String_Output
);
7311 elsif Nam
= TSS_Stream_Read
7312 and then Is_Available
(RE_Wide_String_Read
)
7314 return RTE
(RE_Wide_String_Read
);
7316 elsif Nam
= TSS_Stream_Write
7317 and then Is_Available
(RE_Wide_String_Write
)
7319 return RTE
(RE_Wide_String_Write
);
7321 elsif Nam
/= TSS_Stream_Input
and then
7322 Nam
/= TSS_Stream_Output
and then
7323 Nam
/= TSS_Stream_Read
and then
7324 Nam
/= TSS_Stream_Write
7326 raise Program_Error
;
7329 -- Restriction No_Stream_Optimizations is not set, so we can go
7330 -- ahead and optimize using the block IO forms of the routines.
7333 if Nam
= TSS_Stream_Input
7334 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
7336 return RTE
(RE_Wide_String_Input_Blk_IO
);
7338 elsif Nam
= TSS_Stream_Output
7339 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
7341 return RTE
(RE_Wide_String_Output_Blk_IO
);
7343 elsif Nam
= TSS_Stream_Read
7344 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
7346 return RTE
(RE_Wide_String_Read_Blk_IO
);
7348 elsif Nam
= TSS_Stream_Write
7349 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
7351 return RTE
(RE_Wide_String_Write_Blk_IO
);
7353 elsif Nam
/= TSS_Stream_Input
and then
7354 Nam
/= TSS_Stream_Output
and then
7355 Nam
/= TSS_Stream_Read
and then
7356 Nam
/= TSS_Stream_Write
7358 raise Program_Error
;
7362 -- Wide_Wide_String as defined in package Ada
7364 elsif Base_Typ
= Standard_Wide_Wide_String
then
7366 -- Case of No_Stream_Optimizations restriction active
7368 if Restriction_Active
(No_Stream_Optimizations
) then
7369 if Nam
= TSS_Stream_Input
7370 and then Is_Available
(RE_Wide_Wide_String_Input
)
7372 return RTE
(RE_Wide_Wide_String_Input
);
7374 elsif Nam
= TSS_Stream_Output
7375 and then Is_Available
(RE_Wide_Wide_String_Output
)
7377 return RTE
(RE_Wide_Wide_String_Output
);
7379 elsif Nam
= TSS_Stream_Read
7380 and then Is_Available
(RE_Wide_Wide_String_Read
)
7382 return RTE
(RE_Wide_Wide_String_Read
);
7384 elsif Nam
= TSS_Stream_Write
7385 and then Is_Available
(RE_Wide_Wide_String_Write
)
7387 return RTE
(RE_Wide_Wide_String_Write
);
7389 elsif Nam
/= TSS_Stream_Input
and then
7390 Nam
/= TSS_Stream_Output
and then
7391 Nam
/= TSS_Stream_Read
and then
7392 Nam
/= TSS_Stream_Write
7394 raise Program_Error
;
7397 -- Restriction No_Stream_Optimizations is not set, so we can go
7398 -- ahead and optimize using the block IO forms of the routines.
7401 if Nam
= TSS_Stream_Input
7402 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
7404 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
7406 elsif Nam
= TSS_Stream_Output
7407 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
7409 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
7411 elsif Nam
= TSS_Stream_Read
7412 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
7414 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
7416 elsif Nam
= TSS_Stream_Write
7417 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
7419 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
7421 elsif Nam
/= TSS_Stream_Input
and then
7422 Nam
/= TSS_Stream_Output
and then
7423 Nam
/= TSS_Stream_Read
and then
7424 Nam
/= TSS_Stream_Write
7426 raise Program_Error
;
7432 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
7433 return Find_Prim_Op
(Typ
, Nam
);
7435 return Find_Inherited_TSS
(Typ
, Nam
);
7437 end Find_Stream_Subprogram
;
7443 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
7447 BT
:= Base_Type
(T
);
7449 if Is_Private_Type
(BT
)
7450 and then Present
(Full_View
(BT
))
7452 BT
:= Full_View
(BT
);
7458 -----------------------
7459 -- Get_Index_Subtype --
7460 -----------------------
7462 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
7463 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
7468 if Is_Access_Type
(P_Type
) then
7469 P_Type
:= Designated_Type
(P_Type
);
7472 if No
(Expressions
(N
)) then
7475 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
7478 Indx
:= First_Index
(P_Type
);
7484 return Etype
(Indx
);
7485 end Get_Index_Subtype
;
7487 -------------------------------
7488 -- Get_Stream_Convert_Pragma --
7489 -------------------------------
7491 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
7496 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7497 -- that a stream convert pragma for a tagged type is not inherited from
7498 -- its parent. Probably what is wrong here is that it is basically
7499 -- incorrect to consider a stream convert pragma to be a representation
7500 -- pragma at all ???
7502 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
7503 while Present
(N
) loop
7504 if Nkind
(N
) = N_Pragma
7505 and then Pragma_Name
(N
) = Name_Stream_Convert
7507 -- For tagged types this pragma is not inherited, so we
7508 -- must verify that it is defined for the given type and
7512 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
7514 if not Is_Tagged_Type
(T
)
7516 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
7526 end Get_Stream_Convert_Pragma
;
7528 ---------------------------------
7529 -- Is_Constrained_Packed_Array --
7530 ---------------------------------
7532 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
7533 Arr
: Entity_Id
:= Typ
;
7536 if Is_Access_Type
(Arr
) then
7537 Arr
:= Designated_Type
(Arr
);
7540 return Is_Array_Type
(Arr
)
7541 and then Is_Constrained
(Arr
)
7542 and then Present
(Packed_Array_Type
(Arr
));
7543 end Is_Constrained_Packed_Array
;
7545 ----------------------------------------
7546 -- Is_Inline_Floating_Point_Attribute --
7547 ----------------------------------------
7549 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
7550 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
7553 if Nkind
(Parent
(N
)) /= N_Type_Conversion
7554 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
7559 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
7560 -- required back end support has not been implemented yet ???
7562 return Id
= Attribute_Truncation
;
7563 end Is_Inline_Floating_Point_Attribute
;