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
(Attr
: 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_Pred_Succ
(N
: Node_Id
);
144 -- Handles expansion of Pred or Succ attributes for case of non-real
145 -- operand with overflow checking required.
147 procedure Expand_Update_Attribute
(N
: Node_Id
);
148 -- Handle the expansion of attribute Update
150 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
151 -- Used for Last, Last, and Length, when the prefix is an array type.
152 -- Obtains the corresponding index subtype.
154 procedure Find_Fat_Info
156 Fat_Type
: out Entity_Id
;
157 Fat_Pkg
: out RE_Id
);
158 -- Given a floating-point type T, identifies the package containing the
159 -- attributes for this type (returned in Fat_Pkg), and the corresponding
160 -- type for which this package was instantiated from Fat_Gen. Error if T
161 -- is not a floating-point type.
163 function Find_Stream_Subprogram
165 Nam
: TSS_Name_Type
) return Entity_Id
;
166 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
167 -- types, the corresponding primitive operation is looked up, else the
168 -- appropriate TSS from the type itself, or from its closest ancestor
169 -- defining it, is returned. In both cases, inheritance of representation
170 -- aspects is thus taken into account.
172 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
173 -- The stream functions need to examine the underlying representation of
174 -- composite types. In some cases T may be non-private but its base type
175 -- is, in which case the function returns the corresponding full view.
177 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
178 -- Given a type, find a corresponding stream convert pragma that applies to
179 -- the implementation base type of this type (Typ). If found, return the
180 -- pragma node, otherwise return Empty if no pragma is found.
182 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
183 -- Utility for array attributes, returns true on packed constrained
184 -- arrays, and on access to same.
186 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
187 -- Returns true iff the given node refers to an attribute call that
188 -- can be expanded directly by the back end and does not need front end
189 -- expansion. Typically used for rounding and truncation attributes that
190 -- appear directly inside a conversion to integer.
192 -------------------------
193 -- Build_Array_VS_Func --
194 -------------------------
196 function Build_Array_VS_Func
198 Nod
: Node_Id
) return Entity_Id
200 Loc
: constant Source_Ptr
:= Sloc
(Nod
);
201 Comp_Type
: constant Entity_Id
:= Component_Type
(A_Type
);
202 Body_Stmts
: List_Id
;
203 Index_List
: List_Id
;
207 function Test_Component
return List_Id
;
208 -- Create one statement to test validity of one component designated by
209 -- a full set of indexes. Returns statement list containing test.
211 function Test_One_Dimension
(N
: Int
) return List_Id
;
212 -- Create loop to test one dimension of the array. The single statement
213 -- in the loop body tests the inner dimensions if any, or else the
214 -- single component. Note that this procedure is called recursively,
215 -- with N being the dimension to be initialized. A call with N greater
216 -- than the number of dimensions simply generates the component test,
217 -- terminating the recursion. Returns statement list containing tests.
223 function Test_Component
return List_Id
is
229 Make_Indexed_Component
(Loc
,
230 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
231 Expressions
=> Index_List
);
233 if Is_Scalar_Type
(Comp_Type
) then
236 Anam
:= Name_Valid_Scalars
;
240 Make_If_Statement
(Loc
,
244 Make_Attribute_Reference
(Loc
,
245 Attribute_Name
=> Anam
,
247 Then_Statements
=> New_List
(
248 Make_Simple_Return_Statement
(Loc
,
249 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
252 ------------------------
253 -- Test_One_Dimension --
254 ------------------------
256 function Test_One_Dimension
(N
: Int
) return List_Id
is
260 -- If all dimensions dealt with, we simply test the component
262 if N
> Number_Dimensions
(A_Type
) then
263 return Test_Component
;
265 -- Here we generate the required loop
269 Make_Defining_Identifier
(Loc
, New_External_Name
('J', N
));
271 Append
(New_Reference_To
(Index
, Loc
), Index_List
);
274 Make_Implicit_Loop_Statement
(Nod
,
277 Make_Iteration_Scheme
(Loc
,
278 Loop_Parameter_Specification
=>
279 Make_Loop_Parameter_Specification
(Loc
,
280 Defining_Identifier
=> Index
,
281 Discrete_Subtype_Definition
=>
282 Make_Attribute_Reference
(Loc
,
283 Prefix
=> Make_Identifier
(Loc
, Name_uA
),
284 Attribute_Name
=> Name_Range
,
285 Expressions
=> New_List
(
286 Make_Integer_Literal
(Loc
, N
))))),
287 Statements
=> Test_One_Dimension
(N
+ 1)),
288 Make_Simple_Return_Statement
(Loc
,
289 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
291 end Test_One_Dimension
;
293 -- Start of processing for Build_Array_VS_Func
296 Index_List
:= New_List
;
297 Func_Id
:= Make_Defining_Identifier
(Loc
, New_Internal_Name
('V'));
299 Body_Stmts
:= Test_One_Dimension
(1);
301 -- Parameter is always (A : A_Typ)
303 Formals
:= New_List
(
304 Make_Parameter_Specification
(Loc
,
305 Defining_Identifier
=> Make_Defining_Identifier
(Loc
, Name_uA
),
307 Out_Present
=> False,
308 Parameter_Type
=> New_Reference_To
(A_Type
, Loc
)));
312 Set_Ekind
(Func_Id
, E_Function
);
313 Set_Is_Internal
(Func_Id
);
316 Make_Subprogram_Body
(Loc
,
318 Make_Function_Specification
(Loc
,
319 Defining_Unit_Name
=> Func_Id
,
320 Parameter_Specifications
=> Formals
,
322 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
323 Declarations
=> New_List
,
324 Handled_Statement_Sequence
=>
325 Make_Handled_Sequence_Of_Statements
(Loc
,
326 Statements
=> Body_Stmts
)));
328 if not Debug_Generated_Code
then
329 Set_Debug_Info_Off
(Func_Id
);
333 end Build_Array_VS_Func
;
335 ----------------------------------
336 -- Compile_Stream_Body_In_Scope --
337 ----------------------------------
339 procedure Compile_Stream_Body_In_Scope
345 Installed
: Boolean := False;
346 Scop
: constant Entity_Id
:= Scope
(Arr
);
347 Curr
: constant Entity_Id
:= Current_Scope
;
351 and then not In_Open_Scopes
(Scop
)
352 and then Ekind
(Scop
) = E_Package
355 Install_Visible_Declarations
(Scop
);
356 Install_Private_Declarations
(Scop
);
359 -- The entities in the package are now visible, but the generated
360 -- stream entity must appear in the current scope (usually an
361 -- enclosing stream function) so that itypes all have their proper
368 Insert_Action
(N
, Decl
);
370 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
375 -- Remove extra copy of current scope, and package itself
378 End_Package_Scope
(Scop
);
380 end Compile_Stream_Body_In_Scope
;
382 -----------------------------------
383 -- Expand_Access_To_Protected_Op --
384 -----------------------------------
386 procedure Expand_Access_To_Protected_Op
391 -- The value of the attribute_reference is a record containing two
392 -- fields: an access to the protected object, and an access to the
393 -- subprogram itself. The prefix is a selected component.
395 Loc
: constant Source_Ptr
:= Sloc
(N
);
397 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
400 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
401 Acc
: constant Entity_Id
:=
402 Etype
(Next_Component
(First_Component
(E_T
)));
406 function May_Be_External_Call
return Boolean;
407 -- If the 'Access is to a local operation, but appears in a context
408 -- where it may lead to a call from outside the object, we must treat
409 -- this as an external call. Clearly we cannot tell without full
410 -- flow analysis, and a subsequent call that uses this 'Access may
411 -- lead to a bounded error (trying to seize locks twice, e.g.). For
412 -- now we treat 'Access as a potential external call if it is an actual
413 -- in a call to an outside subprogram.
415 --------------------------
416 -- May_Be_External_Call --
417 --------------------------
419 function May_Be_External_Call
return Boolean is
421 Par
: Node_Id
:= Parent
(N
);
424 -- Account for the case where the Access attribute is part of a
425 -- named parameter association.
427 if Nkind
(Par
) = N_Parameter_Association
then
431 if Nkind
(Par
) in N_Subprogram_Call
432 and then Is_Entity_Name
(Name
(Par
))
434 Subp
:= Entity
(Name
(Par
));
435 return not In_Open_Scopes
(Scope
(Subp
));
439 end May_Be_External_Call
;
441 -- Start of processing for Expand_Access_To_Protected_Op
444 -- Within the body of the protected type, the prefix designates a local
445 -- operation, and the object is the first parameter of the corresponding
446 -- protected body of the current enclosing operation.
448 if Is_Entity_Name
(Pref
) then
449 if May_Be_External_Call
then
451 New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
455 (Protected_Body_Subprogram
(Entity
(Pref
)), Loc
);
458 -- Don't traverse the scopes when the attribute occurs within an init
459 -- proc, because we directly use the _init formal of the init proc in
462 Curr
:= Current_Scope
;
463 if not Is_Init_Proc
(Curr
) then
464 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
466 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
467 Curr
:= Scope
(Curr
);
471 -- In case of protected entries the first formal of its Protected_
472 -- Body_Subprogram is the address of the object.
474 if Ekind
(Curr
) = E_Entry
then
478 (Protected_Body_Subprogram
(Curr
)), Loc
);
480 -- If the current scope is an init proc, then use the address of the
481 -- _init formal as the object reference.
483 elsif Is_Init_Proc
(Curr
) then
485 Make_Attribute_Reference
(Loc
,
486 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
487 Attribute_Name
=> Name_Address
);
489 -- In case of protected subprograms the first formal of its
490 -- Protected_Body_Subprogram is the object and we get its address.
494 Make_Attribute_Reference
(Loc
,
498 (Protected_Body_Subprogram
(Curr
)), Loc
),
499 Attribute_Name
=> Name_Address
);
502 -- Case where the prefix is not an entity name. Find the
503 -- version of the protected operation to be called from
504 -- outside the protected object.
510 (Entity
(Selector_Name
(Pref
))), Loc
);
513 Make_Attribute_Reference
(Loc
,
514 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
515 Attribute_Name
=> Name_Address
);
519 Make_Attribute_Reference
(Loc
,
521 Attribute_Name
=> Name_Access
);
523 -- We set the type of the access reference to the already generated
524 -- access_to_subprogram type, and declare the reference analyzed, to
525 -- prevent further expansion when the enclosing aggregate is analyzed.
527 Set_Etype
(Sub_Ref
, Acc
);
528 Set_Analyzed
(Sub_Ref
);
532 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
534 -- Sub_Ref has been marked as analyzed, but we still need to make sure
535 -- Sub is correctly frozen.
537 Freeze_Before
(N
, Entity
(Sub
));
540 Analyze_And_Resolve
(N
, E_T
);
542 -- For subsequent analysis, the node must retain its type. The backend
543 -- will replace it with the equivalent type where needed.
546 end Expand_Access_To_Protected_Op
;
548 --------------------------
549 -- Expand_Fpt_Attribute --
550 --------------------------
552 procedure Expand_Fpt_Attribute
558 Loc
: constant Source_Ptr
:= Sloc
(N
);
559 Typ
: constant Entity_Id
:= Etype
(N
);
563 -- The function name is the selected component Attr_xxx.yyy where
564 -- Attr_xxx is the package name, and yyy is the argument Nam.
566 -- Note: it would be more usual to have separate RE entries for each
567 -- of the entities in the Fat packages, but first they have identical
568 -- names (so we would have to have lots of renaming declarations to
569 -- meet the normal RE rule of separate names for all runtime entities),
570 -- and second there would be an awful lot of them!
573 Make_Selected_Component
(Loc
,
574 Prefix
=> New_Reference_To
(RTE
(Pkg
), Loc
),
575 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
577 -- The generated call is given the provided set of parameters, and then
578 -- wrapped in a conversion which converts the result to the target type
579 -- We use the base type as the target because a range check may be
583 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
584 Make_Function_Call
(Loc
,
586 Parameter_Associations
=> Args
)));
588 Analyze_And_Resolve
(N
, Typ
);
589 end Expand_Fpt_Attribute
;
591 ----------------------------
592 -- Expand_Fpt_Attribute_R --
593 ----------------------------
595 -- The single argument is converted to its root type to call the
596 -- appropriate runtime function, with the actual call being built
597 -- by Expand_Fpt_Attribute
599 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
600 E1
: constant Node_Id
:= First
(Expressions
(N
));
604 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
606 (N
, Pkg
, Attribute_Name
(N
),
607 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
608 end Expand_Fpt_Attribute_R
;
610 -----------------------------
611 -- Expand_Fpt_Attribute_RI --
612 -----------------------------
614 -- The first argument is converted to its root type and the second
615 -- argument is converted to standard long long integer to call the
616 -- appropriate runtime function, with the actual call being built
617 -- by Expand_Fpt_Attribute
619 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
620 E1
: constant Node_Id
:= First
(Expressions
(N
));
623 E2
: constant Node_Id
:= Next
(E1
);
625 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
627 (N
, Pkg
, Attribute_Name
(N
),
629 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
630 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
631 end Expand_Fpt_Attribute_RI
;
633 -----------------------------
634 -- Expand_Fpt_Attribute_RR --
635 -----------------------------
637 -- The two arguments are converted to their root types to call the
638 -- appropriate runtime function, with the actual call being built
639 -- by Expand_Fpt_Attribute
641 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
642 E1
: constant Node_Id
:= First
(Expressions
(N
));
643 E2
: constant Node_Id
:= Next
(E1
);
648 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
650 (N
, Pkg
, Attribute_Name
(N
),
652 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
653 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
654 end Expand_Fpt_Attribute_RR
;
656 ---------------------------------
657 -- Expand_Loop_Entry_Attribute --
658 ---------------------------------
660 procedure Expand_Loop_Entry_Attribute
(Attr
: Node_Id
) is
661 procedure Build_Conditional_Block
665 If_Stmt
: out Node_Id
;
666 Blk_Stmt
: out Node_Id
);
667 -- Create a block Blk_Stmt with an empty declarative list and a single
668 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
669 -- condition Cond. If_Stmt is Empty when there is no condition provided.
671 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
672 -- Determine whether loop statement N denotes an Ada 2012 iteration over
675 -----------------------------
676 -- Build_Conditional_Block --
677 -----------------------------
679 procedure Build_Conditional_Block
683 If_Stmt
: out Node_Id
;
684 Blk_Stmt
: out Node_Id
)
687 -- Do not reanalyze the original loop statement because it is simply
690 Set_Analyzed
(Loop_Stmt
);
693 Make_Block_Statement
(Loc
,
694 Declarations
=> New_List
,
695 Handled_Statement_Sequence
=>
696 Make_Handled_Sequence_Of_Statements
(Loc
,
697 Statements
=> New_List
(Loop_Stmt
)));
699 if Present
(Cond
) then
701 Make_If_Statement
(Loc
,
703 Then_Statements
=> New_List
(Blk_Stmt
));
707 end Build_Conditional_Block
;
709 ------------------------
710 -- Is_Array_Iteration --
711 ------------------------
713 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
714 Stmt
: constant Node_Id
:= Original_Node
(N
);
718 if Nkind
(Stmt
) = N_Loop_Statement
719 and then Present
(Iteration_Scheme
(Stmt
))
720 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
722 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
725 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
729 end Is_Array_Iteration
;
733 Exprs
: constant List_Id
:= Expressions
(Attr
);
734 Pref
: constant Node_Id
:= Prefix
(Attr
);
735 Typ
: constant Entity_Id
:= Etype
(Pref
);
747 -- Start of processing for Expand_Loop_Entry_Attribute
750 -- Step 1: Find the related loop
752 -- The loop label variant of attribute 'Loop_Entry already has all the
753 -- information in its expression.
755 if Present
(Exprs
) then
756 Loop_Id
:= Entity
(First
(Exprs
));
757 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
759 -- Climb the parent chain to find the nearest enclosing loop. Skip all
760 -- internally generated loops for quantified expressions.
764 while Present
(Loop_Stmt
) loop
765 if Nkind
(Loop_Stmt
) = N_Loop_Statement
766 and then Present
(Identifier
(Loop_Stmt
))
771 Loop_Stmt
:= Parent
(Loop_Stmt
);
774 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
777 Loc
:= Sloc
(Loop_Stmt
);
779 -- Step 2: Transform the loop
781 -- The loop has already been transformed during the expansion of a prior
782 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
784 if Has_Loop_Entry_Attributes
(Loop_Id
) then
786 -- When the related loop name appears as the argument of attribute
787 -- Loop_Entry, the corresponding label construct is the generated
788 -- block statement. This is because the expander reuses the label.
790 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
791 Decls
:= Declarations
(Loop_Stmt
);
793 -- In all other cases, the loop must appear in the handled sequence
794 -- of statements of the generated block.
798 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
799 and then Nkind
(Parent
(Parent
(Loop_Stmt
))) =
802 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
807 -- Transform the loop into a conditional block
810 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
811 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
813 -- Infinite loops are transformed into:
816 -- Temp1 : constant <type of Pref1> := <Pref1>;
818 -- TempN : constant <type of PrefN> := <PrefN>;
821 -- <original source statements with attribute rewrites>
826 Build_Conditional_Block
(Loc
,
828 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
834 -- While loops are transformed into:
836 -- if <Condition> then
838 -- Temp1 : constant <type of Pref1> := <Pref1>;
840 -- TempN : constant <type of PrefN> := <PrefN>;
843 -- <original source statements with attribute rewrites>
844 -- exit when not <Condition>;
849 -- Note that loops over iterators and containers are already
850 -- converted into while loops.
852 elsif Present
(Condition
(Scheme
)) then
854 Cond
: constant Node_Id
:= Condition
(Scheme
);
857 -- Transform the original while loop into an infinite loop
858 -- where the last statement checks the negated condition. This
859 -- placement ensures that the condition will not be evaluated
860 -- twice on the first iteration.
863 -- exit when not <Cond>:
865 Append_To
(Statements
(Loop_Stmt
),
866 Make_Exit_Statement
(Loc
,
867 Condition
=> Make_Op_Not
(Loc
, New_Copy_Tree
(Cond
))));
869 Build_Conditional_Block
(Loc
,
870 Cond
=> Relocate_Node
(Cond
),
871 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
876 -- Ada 2012 iteration over an array is transformed into:
878 -- if <Array_Nam>'Length (1) > 0
879 -- and then <Array_Nam>'Length (N) > 0
882 -- Temp1 : constant <type of Pref1> := <Pref1>;
884 -- TempN : constant <type of PrefN> := <PrefN>;
886 -- for X in ... loop -- multiple loops depending on dims
887 -- <original source statements with attribute rewrites>
892 elsif Is_Array_Iteration
(Loop_Stmt
) then
894 Array_Nam
: constant Entity_Id
:=
895 Entity
(Name
(Iterator_Specification
896 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
897 Num_Dims
: constant Pos
:=
898 Number_Dimensions
(Etype
(Array_Nam
));
899 Cond
: Node_Id
:= Empty
;
903 -- Generate a check which determines whether all dimensions of
904 -- the array are non-null.
906 for Dim
in 1 .. Num_Dims
loop
910 Make_Attribute_Reference
(Loc
,
911 Prefix
=> New_Reference_To
(Array_Nam
, Loc
),
912 Attribute_Name
=> Name_Length
,
913 Expressions
=> New_List
(
914 Make_Integer_Literal
(Loc
, Dim
))),
916 Make_Integer_Literal
(Loc
, 0));
924 Right_Opnd
=> Check
);
928 Build_Conditional_Block
(Loc
,
930 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
935 -- For loops are transformed into:
937 -- if <Low> <= <High> then
939 -- Temp1 : constant <type of Pref1> := <Pref1>;
941 -- TempN : constant <type of PrefN> := <PrefN>;
943 -- for <Def_Id> in <Low> .. <High> loop
944 -- <original source statements with attribute rewrites>
949 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
951 Loop_Spec
: constant Node_Id
:=
952 Loop_Parameter_Specification
(Scheme
);
957 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
959 -- When the loop iterates over a subtype indication with a
960 -- range, use the low and high bounds of the subtype itself.
962 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
963 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
966 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
973 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
974 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
976 Build_Conditional_Block
(Loc
,
978 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
984 Decls
:= Declarations
(Blk
);
987 -- Step 3: Create a constant to capture the value of the prefix at the
988 -- entry point into the loop.
991 -- Temp : constant <type of Pref> := <Pref>;
993 Temp_Id
:= Make_Temporary
(Loc
, 'P');
996 Make_Object_Declaration
(Loc
,
997 Defining_Identifier
=> Temp_Id
,
998 Constant_Present
=> True,
999 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
1000 Expression
=> Relocate_Node
(Pref
));
1001 Append_To
(Decls
, Temp_Decl
);
1003 -- Step 4: Analyze all bits
1005 Rewrite
(Attr
, New_Reference_To
(Temp_Id
, Loc
));
1007 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1009 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1010 -- associated loop, ensure the proper visibility for analysis.
1012 if not Installed
then
1013 Push_Scope
(Scope
(Loop_Id
));
1016 -- The analysis of the conditional block takes care of the constant
1019 if Present
(Result
) then
1020 Rewrite
(Loop_Stmt
, Result
);
1021 Analyze
(Loop_Stmt
);
1023 -- The conditional block was analyzed when a previous 'Loop_Entry was
1024 -- expanded. There is no point in reanalyzing the block, simply analyze
1025 -- the declaration of the constant.
1028 Analyze
(Temp_Decl
);
1033 if not Installed
then
1036 end Expand_Loop_Entry_Attribute
;
1038 ----------------------------------
1039 -- Expand_N_Attribute_Reference --
1040 ----------------------------------
1042 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1043 Loc
: constant Source_Ptr
:= Sloc
(N
);
1044 Typ
: constant Entity_Id
:= Etype
(N
);
1045 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1046 Pref
: constant Node_Id
:= Prefix
(N
);
1047 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
1048 Exprs
: constant List_Id
:= Expressions
(N
);
1049 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
1051 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
1052 -- Rewrites a stream attribute for Read, Write or Output with the
1053 -- procedure call. Pname is the entity for the procedure to call.
1055 ------------------------------
1056 -- Rewrite_Stream_Proc_Call --
1057 ------------------------------
1059 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
1060 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1061 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1062 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1063 Is_Written
: constant Boolean := (Ekind
(Formal
) /= E_In_Parameter
);
1066 -- The expansion depends on Item, the second actual, which is
1067 -- the object being streamed in or out.
1069 -- If the item is a component of a packed array type, and
1070 -- a conversion is needed on exit, we introduce a temporary to
1071 -- hold the value, because otherwise the packed reference will
1072 -- not be properly expanded.
1074 if Nkind
(Item
) = N_Indexed_Component
1075 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1076 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1080 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1086 Make_Object_Declaration
(Loc
,
1087 Defining_Identifier
=> Temp
,
1088 Object_Definition
=>
1089 New_Occurrence_Of
(Formal_Typ
, Loc
));
1090 Set_Etype
(Temp
, Formal_Typ
);
1093 Make_Assignment_Statement
(Loc
,
1094 Name
=> New_Copy_Tree
(Item
),
1096 Unchecked_Convert_To
1097 (Etype
(Item
), New_Occurrence_Of
(Temp
, Loc
)));
1099 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1103 Make_Procedure_Call_Statement
(Loc
,
1104 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1105 Parameter_Associations
=> Exprs
),
1108 Rewrite
(N
, Make_Null_Statement
(Loc
));
1113 -- For the class-wide dispatching cases, and for cases in which
1114 -- the base type of the second argument matches the base type of
1115 -- the corresponding formal parameter (that is to say the stream
1116 -- operation is not inherited), we are all set, and can use the
1117 -- argument unchanged.
1119 -- For all other cases we do an unchecked conversion of the second
1120 -- parameter to the type of the formal of the procedure we are
1121 -- calling. This deals with the private type cases, and with going
1122 -- to the root type as required in elementary type case.
1124 if not Is_Class_Wide_Type
(Entity
(Pref
))
1125 and then not Is_Class_Wide_Type
(Etype
(Item
))
1126 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
1129 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
1131 -- For untagged derived types set Assignment_OK, to prevent
1132 -- copies from being created when the unchecked conversion
1133 -- is expanded (which would happen in Remove_Side_Effects
1134 -- if Expand_N_Unchecked_Conversion were allowed to call
1135 -- Force_Evaluation). The copy could violate Ada semantics
1136 -- in cases such as an actual that is an out parameter.
1137 -- Note that this approach is also used in exp_ch7 for calls
1138 -- to controlled type operations to prevent problems with
1139 -- actuals wrapped in unchecked conversions.
1141 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
1142 Set_Assignment_OK
(Item
);
1146 -- The stream operation to call maybe a renaming created by
1147 -- an attribute definition clause, and may not be frozen yet.
1148 -- Ensure that it has the necessary extra formals.
1150 if not Is_Frozen
(Pname
) then
1151 Create_Extra_Formals
(Pname
);
1154 -- And now rewrite the call
1157 Make_Procedure_Call_Statement
(Loc
,
1158 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1159 Parameter_Associations
=> Exprs
));
1162 end Rewrite_Stream_Proc_Call
;
1164 -- Start of processing for Expand_N_Attribute_Reference
1167 -- Do required validity checking, if enabled. Do not apply check to
1168 -- output parameters of an Asm instruction, since the value of this
1169 -- is not set till after the attribute has been elaborated, and do
1170 -- not apply the check to the arguments of a 'Read or 'Input attribute
1171 -- reference since the scalar argument is an OUT scalar.
1173 if Validity_Checks_On
and then Validity_Check_Operands
1174 and then Id
/= Attribute_Asm_Output
1175 and then Id
/= Attribute_Read
1176 and then Id
/= Attribute_Input
1181 Expr
:= First
(Expressions
(N
));
1182 while Present
(Expr
) loop
1183 Ensure_Valid
(Expr
);
1189 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1190 -- place function, then a temporary return object needs to be created
1191 -- and access to it must be passed to the function. Currently we limit
1192 -- such functions to those with inherently limited result subtypes, but
1193 -- eventually we plan to expand the functions that are treated as
1194 -- build-in-place to include other composite result types.
1196 if Ada_Version
>= Ada_2005
1197 and then Is_Build_In_Place_Function_Call
(Pref
)
1199 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
1202 -- If prefix is a protected type name, this is a reference to the
1203 -- current instance of the type. For a component definition, nothing
1204 -- to do (expansion will occur in the init proc). In other contexts,
1205 -- rewrite into reference to current instance.
1207 if Is_Protected_Self_Reference
(Pref
)
1209 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
1210 N_Discriminant_Association
)
1211 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
1212 N_Component_Definition
)
1214 -- No action needed for these attributes since the current instance
1215 -- will be rewritten to be the name of the _object parameter
1216 -- associated with the enclosing protected subprogram (see below).
1218 and then Id
/= Attribute_Access
1219 and then Id
/= Attribute_Unchecked_Access
1220 and then Id
/= Attribute_Unrestricted_Access
1222 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
1226 -- Remaining processing depends on specific attribute
1228 -- Note: individual sections of the following case statement are
1229 -- allowed to assume there is no code after the case statement, and
1230 -- are legitimately allowed to execute return statements if they have
1231 -- nothing more to do.
1235 -- Attributes related to Ada 2012 iterators (placeholder ???)
1237 when Attribute_Constant_Indexing |
1238 Attribute_Default_Iterator |
1239 Attribute_Implicit_Dereference |
1240 Attribute_Iterator_Element |
1241 Attribute_Variable_Indexing
=>
1244 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1245 -- were already rejected by the parser. Thus they shouldn't appear here.
1247 when Internal_Attribute_Id
=>
1248 raise Program_Error
;
1254 when Attribute_Access |
1255 Attribute_Unchecked_Access |
1256 Attribute_Unrestricted_Access
=>
1258 Access_Cases
: declare
1259 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
1260 Btyp_DDT
: Entity_Id
;
1262 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
1263 -- If N denotes a compound name (selected component, indexed
1264 -- component, or slice), returns the name of the outermost such
1265 -- enclosing object. Otherwise returns N. If the object is a
1266 -- renaming, then the renamed object is returned.
1268 ----------------------
1269 -- Enclosing_Object --
1270 ----------------------
1272 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
1277 while Nkind_In
(Obj_Name
, N_Selected_Component
,
1278 N_Indexed_Component
,
1281 Obj_Name
:= Prefix
(Obj_Name
);
1284 return Get_Referenced_Object
(Obj_Name
);
1285 end Enclosing_Object
;
1287 -- Local declarations
1289 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
1291 -- Start of processing for Access_Cases
1294 Btyp_DDT
:= Designated_Type
(Btyp
);
1296 -- Handle designated types that come from the limited view
1298 if Ekind
(Btyp_DDT
) = E_Incomplete_Type
1299 and then From_With_Type
(Btyp_DDT
)
1300 and then Present
(Non_Limited_View
(Btyp_DDT
))
1302 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
1304 elsif Is_Class_Wide_Type
(Btyp_DDT
)
1305 and then Ekind
(Etype
(Btyp_DDT
)) = E_Incomplete_Type
1306 and then From_With_Type
(Etype
(Btyp_DDT
))
1307 and then Present
(Non_Limited_View
(Etype
(Btyp_DDT
)))
1308 and then Present
(Class_Wide_Type
1309 (Non_Limited_View
(Etype
(Btyp_DDT
))))
1312 Class_Wide_Type
(Non_Limited_View
(Etype
(Btyp_DDT
)));
1315 -- In order to improve the text of error messages, the designated
1316 -- type of access-to-subprogram itypes is set by the semantics as
1317 -- the associated subprogram entity (see sem_attr). Now we replace
1318 -- such node with the proper E_Subprogram_Type itype.
1320 if Id
= Attribute_Unrestricted_Access
1321 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
1323 -- The following conditions ensure that this special management
1324 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
1325 -- At this stage other cases in which the designated type is
1326 -- still a subprogram (instead of an E_Subprogram_Type) are
1327 -- wrong because the semantics must have overridden the type of
1328 -- the node with the type imposed by the context.
1330 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
1331 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
1333 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
1337 Subp
: constant Entity_Id
:=
1338 Directly_Designated_Type
(Typ
);
1340 Extra
: Entity_Id
:= Empty
;
1341 New_Formal
: Entity_Id
;
1342 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
1343 Subp_Typ
: Entity_Id
;
1346 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
1347 Set_Etype
(Subp_Typ
, Etype
(Subp
));
1348 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
1350 if Present
(Old_Formal
) then
1351 New_Formal
:= New_Copy
(Old_Formal
);
1352 Set_First_Entity
(Subp_Typ
, New_Formal
);
1355 Set_Scope
(New_Formal
, Subp_Typ
);
1356 Etyp
:= Etype
(New_Formal
);
1358 -- Handle itypes. There is no need to duplicate
1359 -- here the itypes associated with record types
1360 -- (i.e the implicit full view of private types).
1363 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
1365 Extra
:= New_Copy
(Etyp
);
1366 Set_Parent
(Extra
, New_Formal
);
1367 Set_Etype
(New_Formal
, Extra
);
1368 Set_Scope
(Extra
, Subp_Typ
);
1371 Extra
:= New_Formal
;
1372 Next_Formal
(Old_Formal
);
1373 exit when No
(Old_Formal
);
1375 Set_Next_Entity
(New_Formal
,
1376 New_Copy
(Old_Formal
));
1377 Next_Entity
(New_Formal
);
1380 Set_Next_Entity
(New_Formal
, Empty
);
1381 Set_Last_Entity
(Subp_Typ
, Extra
);
1384 -- Now that the explicit formals have been duplicated,
1385 -- any extra formals needed by the subprogram must be
1388 if Present
(Extra
) then
1389 Set_Extra_Formal
(Extra
, Empty
);
1392 Create_Extra_Formals
(Subp_Typ
);
1393 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
1398 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
1399 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
1401 -- If prefix is a type name, this is a reference to the current
1402 -- instance of the type, within its initialization procedure.
1404 elsif Is_Entity_Name
(Pref
)
1405 and then Is_Type
(Entity
(Pref
))
1412 -- If the current instance name denotes a task type, then
1413 -- the access attribute is rewritten to be the name of the
1414 -- "_task" parameter associated with the task type's task
1415 -- procedure. An unchecked conversion is applied to ensure
1416 -- a type match in cases of expander-generated calls (e.g.
1419 if Is_Task_Type
(Entity
(Pref
)) then
1421 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
1422 while Present
(Formal
) loop
1423 exit when Chars
(Formal
) = Name_uTask
;
1424 Next_Entity
(Formal
);
1427 pragma Assert
(Present
(Formal
));
1430 Unchecked_Convert_To
(Typ
,
1431 New_Occurrence_Of
(Formal
, Loc
)));
1434 elsif Is_Protected_Type
(Entity
(Pref
)) then
1436 -- No action needed for current instance located in a
1437 -- component definition (expansion will occur in the
1440 if Is_Protected_Type
(Current_Scope
) then
1443 -- If the current instance reference is located in a
1444 -- protected subprogram or entry then rewrite the access
1445 -- attribute to be the name of the "_object" parameter.
1446 -- An unchecked conversion is applied to ensure a type
1447 -- match in cases of expander-generated calls (e.g. init
1450 -- The code may be nested in a block, so find enclosing
1451 -- scope that is a protected operation.
1458 Subp
:= Current_Scope
;
1459 while Ekind_In
(Subp
, E_Loop
, E_Block
) loop
1460 Subp
:= Scope
(Subp
);
1465 (Protected_Body_Subprogram
(Subp
));
1467 -- For a protected subprogram the _Object parameter
1468 -- is the protected record, so we create an access
1469 -- to it. The _Object parameter of an entry is an
1472 if Ekind
(Subp
) = E_Entry
then
1474 Unchecked_Convert_To
(Typ
,
1475 New_Occurrence_Of
(Formal
, Loc
)));
1480 Unchecked_Convert_To
(Typ
,
1481 Make_Attribute_Reference
(Loc
,
1482 Attribute_Name
=> Name_Unrestricted_Access
,
1484 New_Occurrence_Of
(Formal
, Loc
))));
1485 Analyze_And_Resolve
(N
);
1490 -- The expression must appear in a default expression,
1491 -- (which in the initialization procedure is the right-hand
1492 -- side of an assignment), and not in a discriminant
1497 while Present
(Par
) loop
1498 exit when Nkind
(Par
) = N_Assignment_Statement
;
1500 if Nkind
(Par
) = N_Component_Declaration
then
1504 Par
:= Parent
(Par
);
1507 if Present
(Par
) then
1509 Make_Attribute_Reference
(Loc
,
1510 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
1511 Attribute_Name
=> Attribute_Name
(N
)));
1513 Analyze_And_Resolve
(N
, Typ
);
1518 -- If the prefix of an Access attribute is a dereference of an
1519 -- access parameter (or a renaming of such a dereference, or a
1520 -- subcomponent of such a dereference) and the context is a
1521 -- general access type (including the type of an object or
1522 -- component with an access_definition, but not the anonymous
1523 -- type of an access parameter or access discriminant), then
1524 -- apply an accessibility check to the access parameter. We used
1525 -- to rewrite the access parameter as a type conversion, but that
1526 -- could only be done if the immediate prefix of the Access
1527 -- attribute was the dereference, and didn't handle cases where
1528 -- the attribute is applied to a subcomponent of the dereference,
1529 -- since there's generally no available, appropriate access type
1530 -- to convert to in that case. The attribute is passed as the
1531 -- point to insert the check, because the access parameter may
1532 -- come from a renaming, possibly in a different scope, and the
1533 -- check must be associated with the attribute itself.
1535 elsif Id
= Attribute_Access
1536 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
1537 and then Is_Entity_Name
(Prefix
(Enc_Object
))
1538 and then (Ekind
(Btyp
) = E_General_Access_Type
1539 or else Is_Local_Anonymous_Access
(Btyp
))
1540 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
1541 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
1542 = E_Anonymous_Access_Type
1543 and then Present
(Extra_Accessibility
1544 (Entity
(Prefix
(Enc_Object
))))
1546 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
1548 -- Ada 2005 (AI-251): If the designated type is an interface we
1549 -- add an implicit conversion to force the displacement of the
1550 -- pointer to reference the secondary dispatch table.
1552 elsif Is_Interface
(Btyp_DDT
)
1553 and then (Comes_From_Source
(N
)
1554 or else Comes_From_Source
(Ref_Object
)
1555 or else (Nkind
(Ref_Object
) in N_Has_Chars
1556 and then Chars
(Ref_Object
) = Name_uInit
))
1558 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
1560 -- No implicit conversion required if types match, or if
1561 -- the prefix is the class_wide_type of the interface. In
1562 -- either case passing an object of the interface type has
1563 -- already set the pointer correctly.
1565 if Btyp_DDT
= Etype
(Ref_Object
)
1566 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
1568 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
1573 Rewrite
(Prefix
(N
),
1574 Convert_To
(Btyp_DDT
,
1575 New_Copy_Tree
(Prefix
(N
))));
1577 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
1580 -- When the object is an explicit dereference, convert the
1581 -- dereference's prefix.
1585 Obj_DDT
: constant Entity_Id
:=
1587 (Directly_Designated_Type
1588 (Etype
(Prefix
(Ref_Object
))));
1590 -- No implicit conversion required if designated types
1591 -- match, or if we have an unrestricted access.
1593 if Obj_DDT
/= Btyp_DDT
1594 and then Id
/= Attribute_Unrestricted_Access
1595 and then not (Is_Class_Wide_Type
(Obj_DDT
)
1596 and then Etype
(Obj_DDT
) = Btyp_DDT
)
1600 New_Copy_Tree
(Prefix
(Ref_Object
))));
1601 Analyze_And_Resolve
(N
, Typ
);
1612 -- Transforms 'Adjacent into a call to the floating-point attribute
1613 -- function Adjacent in Fat_xxx (where xxx is the root type)
1615 when Attribute_Adjacent
=>
1616 Expand_Fpt_Attribute_RR
(N
);
1622 when Attribute_Address
=> Address
: declare
1623 Task_Proc
: Entity_Id
;
1626 -- If the prefix is a task or a task type, the useful address is that
1627 -- of the procedure for the task body, i.e. the actual program unit.
1628 -- We replace the original entity with that of the procedure.
1630 if Is_Entity_Name
(Pref
)
1631 and then Is_Task_Type
(Entity
(Pref
))
1633 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
1635 while Present
(Task_Proc
) loop
1636 exit when Ekind
(Task_Proc
) = E_Procedure
1637 and then Etype
(First_Formal
(Task_Proc
)) =
1638 Corresponding_Record_Type
(Ptyp
);
1639 Next_Entity
(Task_Proc
);
1642 if Present
(Task_Proc
) then
1643 Set_Entity
(Pref
, Task_Proc
);
1644 Set_Etype
(Pref
, Etype
(Task_Proc
));
1647 -- Similarly, the address of a protected operation is the address
1648 -- of the corresponding protected body, regardless of the protected
1649 -- object from which it is selected.
1651 elsif Nkind
(Pref
) = N_Selected_Component
1652 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
1653 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
1657 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
1659 elsif Nkind
(Pref
) = N_Explicit_Dereference
1660 and then Ekind
(Ptyp
) = E_Subprogram_Type
1661 and then Convention
(Ptyp
) = Convention_Protected
1663 -- The prefix is be a dereference of an access_to_protected_
1664 -- subprogram. The desired address is the second component of
1665 -- the record that represents the access.
1668 Addr
: constant Entity_Id
:= Etype
(N
);
1669 Ptr
: constant Node_Id
:= Prefix
(Pref
);
1670 T
: constant Entity_Id
:=
1671 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1675 Unchecked_Convert_To
(Addr
,
1676 Make_Selected_Component
(Loc
,
1677 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1678 Selector_Name
=> New_Occurrence_Of
(
1679 Next_Entity
(First_Entity
(T
)), Loc
))));
1681 Analyze_And_Resolve
(N
, Addr
);
1684 -- Ada 2005 (AI-251): Class-wide interface objects are always
1685 -- "displaced" to reference the tag associated with the interface
1686 -- type. In order to obtain the real address of such objects we
1687 -- generate a call to a run-time subprogram that returns the base
1688 -- address of the object.
1690 -- This processing is not needed in the VM case, where dispatching
1691 -- issues are taken care of by the virtual machine.
1693 elsif Is_Class_Wide_Type
(Ptyp
)
1694 and then Is_Interface
(Ptyp
)
1695 and then Tagged_Type_Expansion
1696 and then not (Nkind
(Pref
) in N_Has_Entity
1697 and then Is_Subprogram
(Entity
(Pref
)))
1700 Make_Function_Call
(Loc
,
1701 Name
=> New_Reference_To
(RTE
(RE_Base_Address
), Loc
),
1702 Parameter_Associations
=> New_List
(
1703 Relocate_Node
(N
))));
1708 -- Deal with packed array reference, other cases are handled by
1711 if Involves_Packed_Array_Reference
(Pref
) then
1712 Expand_Packed_Address_Reference
(N
);
1720 when Attribute_Alignment
=> Alignment
: declare
1724 -- For class-wide types, X'Class'Alignment is transformed into a
1725 -- direct reference to the Alignment of the class type, so that the
1726 -- back end does not have to deal with the X'Class'Alignment
1729 if Is_Entity_Name
(Pref
)
1730 and then Is_Class_Wide_Type
(Entity
(Pref
))
1732 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
1735 -- For x'Alignment applied to an object of a class wide type,
1736 -- transform X'Alignment into a call to the predefined primitive
1737 -- operation _Alignment applied to X.
1739 elsif Is_Class_Wide_Type
(Ptyp
) then
1741 Make_Attribute_Reference
(Loc
,
1743 Attribute_Name
=> Name_Tag
);
1745 if VM_Target
= No_VM
then
1746 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
1749 Make_Function_Call
(Loc
,
1750 Name
=> New_Reference_To
(RTE
(RE_Get_Alignment
), Loc
),
1751 Parameter_Associations
=> New_List
(New_Node
));
1754 -- Case where the context is a specific integer type with which
1755 -- the original attribute was compatible. The function has a
1756 -- specific type as well, so to preserve the compatibility we
1757 -- must convert explicitly.
1759 if Typ
/= Standard_Integer
then
1760 New_Node
:= Convert_To
(Typ
, New_Node
);
1763 Rewrite
(N
, New_Node
);
1764 Analyze_And_Resolve
(N
, Typ
);
1767 -- For all other cases, we just have to deal with the case of
1768 -- the fact that the result can be universal.
1771 Apply_Universal_Integer_Attribute_Checks
(N
);
1779 when Attribute_AST_Entry
=> AST_Entry
: declare
1784 Entry_Ref
: Node_Id
;
1785 -- The reference to the entry or entry family
1788 -- The index expression for an entry family reference, or
1789 -- the Empty if Entry_Ref references a simple entry.
1792 if Nkind
(Pref
) = N_Indexed_Component
then
1793 Entry_Ref
:= Prefix
(Pref
);
1794 Index
:= First
(Expressions
(Pref
));
1800 -- Get expression for Task_Id and the entry entity
1802 if Nkind
(Entry_Ref
) = N_Selected_Component
then
1804 Make_Attribute_Reference
(Loc
,
1805 Attribute_Name
=> Name_Identity
,
1806 Prefix
=> Prefix
(Entry_Ref
));
1808 Ttyp
:= Etype
(Prefix
(Entry_Ref
));
1809 Eent
:= Entity
(Selector_Name
(Entry_Ref
));
1813 Make_Function_Call
(Loc
,
1814 Name
=> New_Occurrence_Of
(RTE
(RE_Current_Task
), Loc
));
1816 Eent
:= Entity
(Entry_Ref
);
1818 -- We have to find the enclosing task to get the task type
1819 -- There must be one, since we already validated this earlier
1821 Ttyp
:= Current_Scope
;
1822 while not Is_Task_Type
(Ttyp
) loop
1823 Ttyp
:= Scope
(Ttyp
);
1827 -- Now rewrite the attribute with a call to Create_AST_Handler
1830 Make_Function_Call
(Loc
,
1831 Name
=> New_Occurrence_Of
(RTE
(RE_Create_AST_Handler
), Loc
),
1832 Parameter_Associations
=> New_List
(
1834 Entry_Index_Expression
(Loc
, Eent
, Index
, Ttyp
))));
1836 Analyze_And_Resolve
(N
, RTE
(RE_AST_Handler
));
1843 -- We compute this if a packed array reference was present, otherwise we
1844 -- leave the computation up to the back end.
1846 when Attribute_Bit
=>
1847 if Involves_Packed_Array_Reference
(Pref
) then
1848 Expand_Packed_Bit_Reference
(N
);
1850 Apply_Universal_Integer_Attribute_Checks
(N
);
1857 -- We compute this if a component clause was present, otherwise we leave
1858 -- the computation up to the back end, since we don't know what layout
1861 -- Note that the attribute can apply to a naked record component
1862 -- in generated code (i.e. the prefix is an identifier that
1863 -- references the component or discriminant entity).
1865 when Attribute_Bit_Position
=> Bit_Position
: declare
1869 if Nkind
(Pref
) = N_Identifier
then
1870 CE
:= Entity
(Pref
);
1872 CE
:= Entity
(Selector_Name
(Pref
));
1875 if Known_Static_Component_Bit_Offset
(CE
) then
1877 Make_Integer_Literal
(Loc
,
1878 Intval
=> Component_Bit_Offset
(CE
)));
1879 Analyze_And_Resolve
(N
, Typ
);
1882 Apply_Universal_Integer_Attribute_Checks
(N
);
1890 -- A reference to P'Body_Version or P'Version is expanded to
1893 -- pragma Import (C, Vnn, "uuuuT");
1895 -- Get_Version_String (Vnn)
1897 -- where uuuu is the unit name (dots replaced by double underscore)
1898 -- and T is B for the cases of Body_Version, or Version applied to a
1899 -- subprogram acting as its own spec, and S for Version applied to a
1900 -- subprogram spec or package. This sequence of code references the
1901 -- unsigned constant created in the main program by the binder.
1903 -- A special exception occurs for Standard, where the string returned
1904 -- is a copy of the library string in gnatvsn.ads.
1906 when Attribute_Body_Version | Attribute_Version
=> Version
: declare
1907 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1912 -- If not library unit, get to containing library unit
1914 Pent
:= Entity
(Pref
);
1915 while Pent
/= Standard_Standard
1916 and then Scope
(Pent
) /= Standard_Standard
1917 and then not Is_Child_Unit
(Pent
)
1919 Pent
:= Scope
(Pent
);
1922 -- Special case Standard and Standard.ASCII
1924 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
1926 Make_String_Literal
(Loc
,
1927 Strval
=> Verbose_Library_Version
));
1932 -- Build required string constant
1934 Get_Name_String
(Get_Unit_Name
(Pent
));
1937 for J
in 1 .. Name_Len
- 2 loop
1938 if Name_Buffer
(J
) = '.' then
1939 Store_String_Chars
("__");
1941 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
1945 -- Case of subprogram acting as its own spec, always use body
1947 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
1948 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
1950 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
1952 Store_String_Chars
("B");
1954 -- Case of no body present, always use spec
1956 elsif not Unit_Requires_Body
(Pent
) then
1957 Store_String_Chars
("S");
1959 -- Otherwise use B for Body_Version, S for spec
1961 elsif Id
= Attribute_Body_Version
then
1962 Store_String_Chars
("B");
1964 Store_String_Chars
("S");
1968 Lib
.Version_Referenced
(S
);
1970 -- Insert the object declaration
1972 Insert_Actions
(N
, New_List
(
1973 Make_Object_Declaration
(Loc
,
1974 Defining_Identifier
=> E
,
1975 Object_Definition
=>
1976 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
1978 -- Set entity as imported with correct external name
1980 Set_Is_Imported
(E
);
1981 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
1983 -- Set entity as internal to ensure proper Sprint output of its
1984 -- implicit importation.
1986 Set_Is_Internal
(E
);
1988 -- And now rewrite original reference
1991 Make_Function_Call
(Loc
,
1992 Name
=> New_Reference_To
(RTE
(RE_Get_Version_String
), Loc
),
1993 Parameter_Associations
=> New_List
(
1994 New_Occurrence_Of
(E
, Loc
))));
1997 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2004 -- Transforms 'Ceiling into a call to the floating-point attribute
2005 -- function Ceiling in Fat_xxx (where xxx is the root type)
2007 when Attribute_Ceiling
=>
2008 Expand_Fpt_Attribute_R
(N
);
2014 -- Transforms 'Callable attribute into a call to the Callable function
2016 when Attribute_Callable
=> Callable
:
2018 -- We have an object of a task interface class-wide type as a prefix
2019 -- to Callable. Generate:
2020 -- callable (Task_Id (Pref._disp_get_task_id));
2022 if Ada_Version
>= Ada_2005
2023 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2024 and then Is_Interface
(Ptyp
)
2025 and then Is_Task_Interface
(Ptyp
)
2028 Make_Function_Call
(Loc
,
2030 New_Reference_To
(RTE
(RE_Callable
), Loc
),
2031 Parameter_Associations
=> New_List
(
2032 Make_Unchecked_Type_Conversion
(Loc
,
2034 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
2036 Make_Selected_Component
(Loc
,
2038 New_Copy_Tree
(Pref
),
2040 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
2044 Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2047 Analyze_And_Resolve
(N
, Standard_Boolean
);
2054 -- Transforms 'Caller attribute into a call to either the
2055 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2057 when Attribute_Caller
=> Caller
: declare
2058 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2059 Ent
: constant Entity_Id
:= Entity
(Pref
);
2060 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2061 Nest_Depth
: Integer := 0;
2068 if Is_Protected_Type
(Conctype
) then
2069 case Corresponding_Runtime_Package
(Conctype
) is
2070 when System_Tasking_Protected_Objects_Entries
=>
2073 (RTE
(RE_Protected_Entry_Caller
), Loc
);
2075 when System_Tasking_Protected_Objects_Single_Entry
=>
2078 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
2081 raise Program_Error
;
2085 Unchecked_Convert_To
(Id_Kind
,
2086 Make_Function_Call
(Loc
,
2088 Parameter_Associations
=> New_List
(
2090 (Find_Protection_Object
(Current_Scope
), Loc
)))));
2095 -- Determine the nesting depth of the E'Caller attribute, that
2096 -- is, how many accept statements are nested within the accept
2097 -- statement for E at the point of E'Caller. The runtime uses
2098 -- this depth to find the specified entry call.
2100 for J
in reverse 0 .. Scope_Stack
.Last
loop
2101 S
:= Scope_Stack
.Table
(J
).Entity
;
2103 -- We should not reach the scope of the entry, as it should
2104 -- already have been checked in Sem_Attr that this attribute
2105 -- reference is within a matching accept statement.
2107 pragma Assert
(S
/= Conctype
);
2112 elsif Is_Entry
(S
) then
2113 Nest_Depth
:= Nest_Depth
+ 1;
2118 Unchecked_Convert_To
(Id_Kind
,
2119 Make_Function_Call
(Loc
,
2121 New_Reference_To
(RTE
(RE_Task_Entry_Caller
), Loc
),
2122 Parameter_Associations
=> New_List
(
2123 Make_Integer_Literal
(Loc
,
2124 Intval
=> Int
(Nest_Depth
))))));
2127 Analyze_And_Resolve
(N
, Id_Kind
);
2134 -- Transforms 'Compose into a call to the floating-point attribute
2135 -- function Compose in Fat_xxx (where xxx is the root type)
2137 -- Note: we strictly should have special code here to deal with the
2138 -- case of absurdly negative arguments (less than Integer'First)
2139 -- which will return a (signed) zero value, but it hardly seems
2140 -- worth the effort. Absurdly large positive arguments will raise
2141 -- constraint error which is fine.
2143 when Attribute_Compose
=>
2144 Expand_Fpt_Attribute_RI
(N
);
2150 when Attribute_Constrained
=> Constrained
: declare
2151 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
2153 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
2154 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2155 -- view of an aliased object whose subtype is constrained.
2157 ---------------------------------
2158 -- Is_Constrained_Aliased_View --
2159 ---------------------------------
2161 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
2165 if Is_Entity_Name
(Obj
) then
2168 if Present
(Renamed_Object
(E
)) then
2169 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
2171 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
2175 return Is_Aliased_View
(Obj
)
2177 (Is_Constrained
(Etype
(Obj
))
2179 (Nkind
(Obj
) = N_Explicit_Dereference
2181 not Object_Type_Has_Constrained_Partial_View
2182 (Typ
=> Base_Type
(Etype
(Obj
)),
2183 Scop
=> Current_Scope
)));
2185 end Is_Constrained_Aliased_View
;
2187 -- Start of processing for Constrained
2190 -- Reference to a parameter where the value is passed as an extra
2191 -- actual, corresponding to the extra formal referenced by the
2192 -- Extra_Constrained field of the corresponding formal. If this
2193 -- is an entry in-parameter, it is replaced by a constant renaming
2194 -- for which Extra_Constrained is never created.
2196 if Present
(Formal_Ent
)
2197 and then Ekind
(Formal_Ent
) /= E_Constant
2198 and then Present
(Extra_Constrained
(Formal_Ent
))
2202 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
2204 -- For variables with a Extra_Constrained field, we use the
2205 -- corresponding entity.
2207 elsif Nkind
(Pref
) = N_Identifier
2208 and then Ekind
(Entity
(Pref
)) = E_Variable
2209 and then Present
(Extra_Constrained
(Entity
(Pref
)))
2213 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
2215 -- For all other entity names, we can tell at compile time
2217 elsif Is_Entity_Name
(Pref
) then
2219 Ent
: constant Entity_Id
:= Entity
(Pref
);
2223 -- (RM J.4) obsolescent cases
2225 if Is_Type
(Ent
) then
2229 if Is_Private_Type
(Ent
) then
2230 Res
:= not Has_Discriminants
(Ent
)
2231 or else Is_Constrained
(Ent
);
2233 -- It not a private type, must be a generic actual type
2234 -- that corresponded to a private type. We know that this
2235 -- correspondence holds, since otherwise the reference
2236 -- within the generic template would have been illegal.
2239 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
2240 Res
:= Is_Constrained
(Ent
);
2246 -- If the prefix is not a variable or is aliased, then
2247 -- definitely true; if it's a formal parameter without an
2248 -- associated extra formal, then treat it as constrained.
2250 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2251 -- constrained in order to set the attribute to True.
2253 elsif not Is_Variable
(Pref
)
2254 or else Present
(Formal_Ent
)
2255 or else (Ada_Version
< Ada_2005
2256 and then Is_Aliased_View
(Pref
))
2257 or else (Ada_Version
>= Ada_2005
2258 and then Is_Constrained_Aliased_View
(Pref
))
2262 -- Variable case, look at type to see if it is constrained.
2263 -- Note that the one case where this is not accurate (the
2264 -- procedure formal case), has been handled above.
2266 -- We use the Underlying_Type here (and below) in case the
2267 -- type is private without discriminants, but the full type
2268 -- has discriminants. This case is illegal, but we generate it
2269 -- internally for passing to the Extra_Constrained parameter.
2272 -- In Ada 2012, test for case of a limited tagged type, in
2273 -- which case the attribute is always required to return
2274 -- True. The underlying type is tested, to make sure we also
2275 -- return True for cases where there is an unconstrained
2276 -- object with an untagged limited partial view which has
2277 -- defaulted discriminants (such objects always produce a
2278 -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
2280 Res
:= Is_Constrained
(Underlying_Type
(Etype
(Ent
)))
2282 (Ada_Version
>= Ada_2012
2283 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2284 and then Is_Limited_Type
(Ptyp
));
2287 Rewrite
(N
, New_Reference_To
(Boolean_Literals
(Res
), Loc
));
2290 -- Prefix is not an entity name. These are also cases where we can
2291 -- always tell at compile time by looking at the form and type of the
2292 -- prefix. If an explicit dereference of an object with constrained
2293 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2294 -- underlying type is a limited tagged type, then Constrained is
2295 -- required to always return True (Ada 2012: AI05-0214).
2301 not Is_Variable
(Pref
)
2303 (Nkind
(Pref
) = N_Explicit_Dereference
2305 not Object_Type_Has_Constrained_Partial_View
2306 (Typ
=> Base_Type
(Ptyp
),
2307 Scop
=> Current_Scope
))
2308 or else Is_Constrained
(Underlying_Type
(Ptyp
))
2309 or else (Ada_Version
>= Ada_2012
2310 and then Is_Tagged_Type
(Underlying_Type
(Ptyp
))
2311 and then Is_Limited_Type
(Ptyp
))),
2315 Analyze_And_Resolve
(N
, Standard_Boolean
);
2322 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2323 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2325 when Attribute_Copy_Sign
=>
2326 Expand_Fpt_Attribute_RR
(N
);
2332 -- Transforms 'Count attribute into a call to the Count function
2334 when Attribute_Count
=> Count
: declare
2336 Conctyp
: Entity_Id
;
2338 Entry_Id
: Entity_Id
;
2343 -- If the prefix is a member of an entry family, retrieve both
2344 -- entry name and index. For a simple entry there is no index.
2346 if Nkind
(Pref
) = N_Indexed_Component
then
2347 Entnam
:= Prefix
(Pref
);
2348 Index
:= First
(Expressions
(Pref
));
2354 Entry_Id
:= Entity
(Entnam
);
2356 -- Find the concurrent type in which this attribute is referenced
2357 -- (there had better be one).
2359 Conctyp
:= Current_Scope
;
2360 while not Is_Concurrent_Type
(Conctyp
) loop
2361 Conctyp
:= Scope
(Conctyp
);
2366 if Is_Protected_Type
(Conctyp
) then
2367 case Corresponding_Runtime_Package
(Conctyp
) is
2368 when System_Tasking_Protected_Objects_Entries
=>
2369 Name
:= New_Reference_To
(RTE
(RE_Protected_Count
), Loc
);
2372 Make_Function_Call
(Loc
,
2374 Parameter_Associations
=> New_List
(
2376 (Find_Protection_Object
(Current_Scope
), Loc
),
2377 Entry_Index_Expression
2378 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
2380 when System_Tasking_Protected_Objects_Single_Entry
=>
2382 New_Reference_To
(RTE
(RE_Protected_Count_Entry
), Loc
);
2385 Make_Function_Call
(Loc
,
2387 Parameter_Associations
=> New_List
(
2389 (Find_Protection_Object
(Current_Scope
), Loc
)));
2392 raise Program_Error
;
2399 Make_Function_Call
(Loc
,
2400 Name
=> New_Reference_To
(RTE
(RE_Task_Count
), Loc
),
2401 Parameter_Associations
=> New_List
(
2402 Entry_Index_Expression
(Loc
,
2403 Entry_Id
, Index
, Scope
(Entry_Id
))));
2406 -- The call returns type Natural but the context is universal integer
2407 -- so any integer type is allowed. The attribute was already resolved
2408 -- so its Etype is the required result type. If the base type of the
2409 -- context type is other than Standard.Integer we put in a conversion
2410 -- to the required type. This can be a normal typed conversion since
2411 -- both input and output types of the conversion are integer types
2413 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
2414 Rewrite
(N
, Convert_To
(Typ
, Call
));
2419 Analyze_And_Resolve
(N
, Typ
);
2422 ---------------------
2423 -- Descriptor_Size --
2424 ---------------------
2426 when Attribute_Descriptor_Size
=>
2428 -- Attribute Descriptor_Size is handled by the back end when applied
2429 -- to an unconstrained array type.
2431 if Is_Array_Type
(Ptyp
)
2432 and then not Is_Constrained
(Ptyp
)
2434 Apply_Universal_Integer_Attribute_Checks
(N
);
2436 -- For any other type, the descriptor size is 0 because there is no
2437 -- actual descriptor, but the result is not formally static.
2440 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
2442 Set_Is_Static_Expression
(N
, False);
2449 -- This processing is shared by Elab_Spec
2451 -- What we do is to insert the following declarations
2454 -- pragma Import (C, enn, "name___elabb/s");
2456 -- and then the Elab_Body/Spec attribute is replaced by a reference
2457 -- to this defining identifier.
2459 when Attribute_Elab_Body |
2460 Attribute_Elab_Spec
=>
2462 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
2463 -- back-end knows how to handle these attributes directly.
2465 if CodePeer_Mode
then
2470 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
2474 procedure Make_Elab_String
(Nod
: Node_Id
);
2475 -- Given Nod, an identifier, or a selected component, put the
2476 -- image into the current string literal, with double underline
2477 -- between components.
2479 ----------------------
2480 -- Make_Elab_String --
2481 ----------------------
2483 procedure Make_Elab_String
(Nod
: Node_Id
) is
2485 if Nkind
(Nod
) = N_Selected_Component
then
2486 Make_Elab_String
(Prefix
(Nod
));
2490 Store_String_Char
('$');
2492 Store_String_Char
('.');
2494 Store_String_Char
('_');
2495 Store_String_Char
('_');
2498 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
2501 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
2502 Get_Name_String
(Chars
(Nod
));
2505 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
2506 end Make_Elab_String
;
2508 -- Start of processing for Elab_Body/Elab_Spec
2511 -- First we need to prepare the string literal for the name of
2512 -- the elaboration routine to be referenced.
2515 Make_Elab_String
(Pref
);
2517 if VM_Target
= No_VM
then
2518 Store_String_Chars
("___elab");
2519 Lang
:= Make_Identifier
(Loc
, Name_C
);
2521 Store_String_Chars
("._elab");
2522 Lang
:= Make_Identifier
(Loc
, Name_Ada
);
2525 if Id
= Attribute_Elab_Body
then
2526 Store_String_Char
('b');
2528 Store_String_Char
('s');
2533 Insert_Actions
(N
, New_List
(
2534 Make_Subprogram_Declaration
(Loc
,
2536 Make_Procedure_Specification
(Loc
,
2537 Defining_Unit_Name
=> Ent
)),
2540 Chars
=> Name_Import
,
2541 Pragma_Argument_Associations
=> New_List
(
2542 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
2544 Make_Pragma_Argument_Association
(Loc
,
2545 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
2547 Make_Pragma_Argument_Association
(Loc
,
2548 Expression
=> Make_String_Literal
(Loc
, Str
))))));
2550 Set_Entity
(N
, Ent
);
2551 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
2554 --------------------
2555 -- Elab_Subp_Body --
2556 --------------------
2558 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
2559 -- this attribute directly, and if we are not in CodePeer mode it is
2560 -- entirely ignored ???
2562 when Attribute_Elab_Subp_Body
=>
2569 -- Elaborated is always True for preelaborated units, predefined units,
2570 -- pure units and units which have Elaborate_Body pragmas. These units
2571 -- have no elaboration entity.
2573 -- Note: The Elaborated attribute is never passed to the back end
2575 when Attribute_Elaborated
=> Elaborated
: declare
2576 Ent
: constant Entity_Id
:= Entity
(Pref
);
2579 if Present
(Elaboration_Entity
(Ent
)) then
2583 New_Occurrence_Of
(Elaboration_Entity
(Ent
), Loc
),
2585 Make_Integer_Literal
(Loc
, Uint_0
)));
2586 Analyze_And_Resolve
(N
, Typ
);
2588 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
2596 when Attribute_Enum_Rep
=> Enum_Rep
:
2598 -- X'Enum_Rep (Y) expands to
2602 -- This is simply a direct conversion from the enumeration type to
2603 -- the target integer type, which is treated by the back end as a
2604 -- normal integer conversion, treating the enumeration type as an
2605 -- integer, which is exactly what we want! We set Conversion_OK to
2606 -- make sure that the analyzer does not complain about what otherwise
2607 -- might be an illegal conversion.
2609 if Is_Non_Empty_List
(Exprs
) then
2611 OK_Convert_To
(Typ
, Relocate_Node
(First
(Exprs
))));
2613 -- X'Enum_Rep where X is an enumeration literal is replaced by
2614 -- the literal value.
2616 elsif Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
then
2618 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Pref
))));
2620 -- If this is a renaming of a literal, recover the representation
2623 elsif Ekind
(Entity
(Pref
)) = E_Constant
2624 and then Present
(Renamed_Object
(Entity
(Pref
)))
2626 Ekind
(Entity
(Renamed_Object
(Entity
(Pref
))))
2627 = E_Enumeration_Literal
2630 Make_Integer_Literal
(Loc
,
2631 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Pref
))))));
2633 -- X'Enum_Rep where X is an object does a direct unchecked conversion
2634 -- of the object value, as described for the type case above.
2638 OK_Convert_To
(Typ
, Relocate_Node
(Pref
)));
2642 Analyze_And_Resolve
(N
, Typ
);
2649 when Attribute_Enum_Val
=> Enum_Val
: declare
2651 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
2654 -- X'Enum_Val (Y) expands to
2656 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
2659 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
2662 Make_Raise_Constraint_Error
(Loc
,
2666 Make_Function_Call
(Loc
,
2668 New_Reference_To
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
2669 Parameter_Associations
=> New_List
(
2670 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
2671 New_Occurrence_Of
(Standard_False
, Loc
))),
2673 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
2674 Reason
=> CE_Range_Check_Failed
));
2677 Analyze_And_Resolve
(N
, Ptyp
);
2684 -- Transforms 'Exponent into a call to the floating-point attribute
2685 -- function Exponent in Fat_xxx (where xxx is the root type)
2687 when Attribute_Exponent
=>
2688 Expand_Fpt_Attribute_R
(N
);
2694 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2696 when Attribute_External_Tag
=> External_Tag
:
2699 Make_Function_Call
(Loc
,
2700 Name
=> New_Reference_To
(RTE
(RE_External_Tag
), Loc
),
2701 Parameter_Associations
=> New_List
(
2702 Make_Attribute_Reference
(Loc
,
2703 Attribute_Name
=> Name_Tag
,
2704 Prefix
=> Prefix
(N
)))));
2706 Analyze_And_Resolve
(N
, Standard_String
);
2713 when Attribute_First
=>
2715 -- If the prefix type is a constrained packed array type which
2716 -- already has a Packed_Array_Type representation defined, then
2717 -- replace this attribute with a direct reference to 'First of the
2718 -- appropriate index subtype (since otherwise the back end will try
2719 -- to give us the value of 'First for this implementation type).
2721 if Is_Constrained_Packed_Array
(Ptyp
) then
2723 Make_Attribute_Reference
(Loc
,
2724 Attribute_Name
=> Name_First
,
2725 Prefix
=> New_Reference_To
(Get_Index_Subtype
(N
), Loc
)));
2726 Analyze_And_Resolve
(N
, Typ
);
2728 elsif Is_Access_Type
(Ptyp
) then
2729 Apply_Access_Check
(N
);
2736 -- Compute this if component clause was present, otherwise we leave the
2737 -- computation to be completed in the back-end, since we don't know what
2738 -- layout will be chosen.
2740 when Attribute_First_Bit
=> First_Bit_Attr
: declare
2741 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
2744 -- In Ada 2005 (or later) if we have the non-default bit order, then
2745 -- we return the original value as given in the component clause
2746 -- (RM 2005 13.5.2(3/2)).
2748 if Present
(Component_Clause
(CE
))
2749 and then Ada_Version
>= Ada_2005
2750 and then Reverse_Bit_Order
(Scope
(CE
))
2753 Make_Integer_Literal
(Loc
,
2754 Intval
=> Expr_Value
(First_Bit
(Component_Clause
(CE
)))));
2755 Analyze_And_Resolve
(N
, Typ
);
2757 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
2758 -- rewrite with normalized value if we know it statically.
2760 elsif Known_Static_Component_Bit_Offset
(CE
) then
2762 Make_Integer_Literal
(Loc
,
2763 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
2764 Analyze_And_Resolve
(N
, Typ
);
2766 -- Otherwise left to back end, just do universal integer checks
2769 Apply_Universal_Integer_Attribute_Checks
(N
);
2779 -- fixtype'Fixed_Value (integer-value)
2783 -- fixtype(integer-value)
2785 -- We do all the required analysis of the conversion here, because we do
2786 -- not want this to go through the fixed-point conversion circuits. Note
2787 -- that the back end always treats fixed-point as equivalent to the
2788 -- corresponding integer type anyway.
2790 when Attribute_Fixed_Value
=> Fixed_Value
:
2793 Make_Type_Conversion
(Loc
,
2794 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
2795 Expression
=> Relocate_Node
(First
(Exprs
))));
2796 Set_Etype
(N
, Entity
(Pref
));
2799 -- Note: it might appear that a properly analyzed unchecked conversion
2800 -- would be just fine here, but that's not the case, since the full
2801 -- range checks performed by the following call are critical!
2803 Apply_Type_Conversion_Checks
(N
);
2810 -- Transforms 'Floor into a call to the floating-point attribute
2811 -- function Floor in Fat_xxx (where xxx is the root type)
2813 when Attribute_Floor
=>
2814 Expand_Fpt_Attribute_R
(N
);
2820 -- For the fixed-point type Typ:
2826 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2827 -- Universal_Real (Type'Last))
2829 -- Note that we know that the type is a non-static subtype, or Fore
2830 -- would have itself been computed dynamically in Eval_Attribute.
2832 when Attribute_Fore
=> Fore
: begin
2835 Make_Function_Call
(Loc
,
2836 Name
=> New_Reference_To
(RTE
(RE_Fore
), Loc
),
2838 Parameter_Associations
=> New_List
(
2839 Convert_To
(Universal_Real
,
2840 Make_Attribute_Reference
(Loc
,
2841 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2842 Attribute_Name
=> Name_First
)),
2844 Convert_To
(Universal_Real
,
2845 Make_Attribute_Reference
(Loc
,
2846 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2847 Attribute_Name
=> Name_Last
))))));
2849 Analyze_And_Resolve
(N
, Typ
);
2856 -- Transforms 'Fraction into a call to the floating-point attribute
2857 -- function Fraction in Fat_xxx (where xxx is the root type)
2859 when Attribute_Fraction
=>
2860 Expand_Fpt_Attribute_R
(N
);
2866 when Attribute_From_Any
=> From_Any
: declare
2867 P_Type
: constant Entity_Id
:= Etype
(Pref
);
2868 Decls
: constant List_Id
:= New_List
;
2871 Build_From_Any_Call
(P_Type
,
2872 Relocate_Node
(First
(Exprs
)),
2874 Insert_Actions
(N
, Decls
);
2875 Analyze_And_Resolve
(N
, P_Type
);
2882 -- For an exception returns a reference to the exception data:
2883 -- Exception_Id!(Prefix'Reference)
2885 -- For a task it returns a reference to the _task_id component of
2886 -- corresponding record:
2888 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2890 -- in Ada.Task_Identification
2892 when Attribute_Identity
=> Identity
: declare
2893 Id_Kind
: Entity_Id
;
2896 if Ptyp
= Standard_Exception_Type
then
2897 Id_Kind
:= RTE
(RE_Exception_Id
);
2899 if Present
(Renamed_Object
(Entity
(Pref
))) then
2900 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
2904 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
2906 Id_Kind
:= RTE
(RO_AT_Task_Id
);
2908 -- If the prefix is a task interface, the Task_Id is obtained
2909 -- dynamically through a dispatching call, as for other task
2910 -- attributes applied to interfaces.
2912 if Ada_Version
>= Ada_2005
2913 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2914 and then Is_Interface
(Ptyp
)
2915 and then Is_Task_Interface
(Ptyp
)
2918 Unchecked_Convert_To
(Id_Kind
,
2919 Make_Selected_Component
(Loc
,
2921 New_Copy_Tree
(Pref
),
2923 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))));
2927 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
2931 Analyze_And_Resolve
(N
, Id_Kind
);
2938 -- Image attribute is handled in separate unit Exp_Imgv
2940 when Attribute_Image
=>
2941 Exp_Imgv
.Expand_Image_Attribute
(N
);
2947 -- X'Img is expanded to typ'Image (X), where typ is the type of X
2949 when Attribute_Img
=> Img
:
2952 Make_Attribute_Reference
(Loc
,
2953 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2954 Attribute_Name
=> Name_Image
,
2955 Expressions
=> New_List
(Relocate_Node
(Pref
))));
2957 Analyze_And_Resolve
(N
, Standard_String
);
2964 when Attribute_Input
=> Input
: declare
2965 P_Type
: constant Entity_Id
:= Entity
(Pref
);
2966 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
2967 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
2968 Strm
: constant Node_Id
:= First
(Exprs
);
2976 Cntrl
: Node_Id
:= Empty
;
2977 -- Value for controlling argument in call. Always Empty except in
2978 -- the dispatching (class-wide type) case, where it is a reference
2979 -- to the dummy object initialized to the right internal tag.
2981 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
2982 -- The expansion of the attribute reference may generate a call to
2983 -- a user-defined stream subprogram that is frozen by the call. This
2984 -- can lead to access-before-elaboration problem if the reference
2985 -- appears in an object declaration and the subprogram body has not
2986 -- been seen. The freezing of the subprogram requires special code
2987 -- because it appears in an expanded context where expressions do
2988 -- not freeze their constituents.
2990 ------------------------------
2991 -- Freeze_Stream_Subprogram --
2992 ------------------------------
2994 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
2995 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
2999 -- If this is user-defined subprogram, the corresponding
3000 -- stream function appears as a renaming-as-body, and the
3001 -- user subprogram must be retrieved by tree traversal.
3004 and then Nkind
(Decl
) = N_Subprogram_Declaration
3005 and then Present
(Corresponding_Body
(Decl
))
3007 Bod
:= Corresponding_Body
(Decl
);
3009 if Nkind
(Unit_Declaration_Node
(Bod
)) =
3010 N_Subprogram_Renaming_Declaration
3012 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
3015 end Freeze_Stream_Subprogram
;
3017 -- Start of processing for Input
3020 -- If no underlying type, we have an error that will be diagnosed
3021 -- elsewhere, so here we just completely ignore the expansion.
3027 -- If there is a TSS for Input, just call it
3029 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
3031 if Present
(Fname
) then
3035 -- If there is a Stream_Convert pragma, use it, we rewrite
3037 -- sourcetyp'Input (stream)
3041 -- sourcetyp (streamread (strmtyp'Input (stream)));
3043 -- where streamread is the given Read function that converts an
3044 -- argument of type strmtyp to type sourcetyp or a type from which
3045 -- it is derived (extra conversion required for the derived case).
3047 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3049 if Present
(Prag
) then
3050 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3051 Rfunc
:= Entity
(Expression
(Arg2
));
3055 Make_Function_Call
(Loc
,
3056 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3057 Parameter_Associations
=> New_List
(
3058 Make_Attribute_Reference
(Loc
,
3061 (Etype
(First_Formal
(Rfunc
)), Loc
),
3062 Attribute_Name
=> Name_Input
,
3063 Expressions
=> Exprs
)))));
3065 Analyze_And_Resolve
(N
, B_Type
);
3070 elsif Is_Elementary_Type
(U_Type
) then
3072 -- A special case arises if we have a defined _Read routine,
3073 -- since in this case we are required to call this routine.
3075 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Read
)) then
3076 Build_Record_Or_Elementary_Input_Function
3077 (Loc
, U_Type
, Decl
, Fname
);
3078 Insert_Action
(N
, Decl
);
3080 -- For normal cases, we call the I_xxx routine directly
3083 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
3084 Analyze_And_Resolve
(N
, P_Type
);
3090 elsif Is_Array_Type
(U_Type
) then
3091 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
3092 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3094 -- Dispatching case with class-wide type
3096 elsif Is_Class_Wide_Type
(P_Type
) then
3098 -- No need to do anything else compiling under restriction
3099 -- No_Dispatching_Calls. During the semantic analysis we
3100 -- already notified such violation.
3102 if Restriction_Active
(No_Dispatching_Calls
) then
3107 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
3113 -- Read the internal tag (RM 13.13.2(34)) and use it to
3114 -- initialize a dummy tag object:
3116 -- Dnn : Ada.Tags.Tag :=
3117 -- Descendant_Tag (String'Input (Strm), P_Type);
3119 -- This dummy object is used only to provide a controlling
3120 -- argument for the eventual _Input call. Descendant_Tag is
3121 -- called rather than Internal_Tag to ensure that we have a
3122 -- tag for a type that is descended from the prefix type and
3123 -- declared at the same accessibility level (the exception
3124 -- Tag_Error will be raised otherwise). The level check is
3125 -- required for Ada 2005 because tagged types can be
3126 -- extended in nested scopes (AI-344).
3129 Make_Function_Call
(Loc
,
3131 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
3132 Parameter_Associations
=> New_List
(
3133 Make_Attribute_Reference
(Loc
,
3134 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
3135 Attribute_Name
=> Name_Input
,
3136 Expressions
=> New_List
(
3137 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
3138 Make_Attribute_Reference
(Loc
,
3139 Prefix
=> New_Reference_To
(P_Type
, Loc
),
3140 Attribute_Name
=> Name_Tag
)));
3142 Dnn
:= Make_Temporary
(Loc
, 'D', Expr
);
3145 Make_Object_Declaration
(Loc
,
3146 Defining_Identifier
=> Dnn
,
3147 Object_Definition
=>
3148 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
3149 Expression
=> Expr
);
3151 Insert_Action
(N
, Decl
);
3153 -- Now we need to get the entity for the call, and construct
3154 -- a function call node, where we preset a reference to Dnn
3155 -- as the controlling argument (doing an unchecked convert
3156 -- to the class-wide tagged type to make it look like a real
3159 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
3161 Unchecked_Convert_To
(P_Type
,
3162 New_Occurrence_Of
(Dnn
, Loc
));
3163 Set_Etype
(Cntrl
, P_Type
);
3164 Set_Parent
(Cntrl
, N
);
3167 -- For tagged types, use the primitive Input function
3169 elsif Is_Tagged_Type
(U_Type
) then
3170 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
3172 -- All other record type cases, including protected records. The
3173 -- latter only arise for expander generated code for handling
3174 -- shared passive partition access.
3178 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3180 -- Ada 2005 (AI-216): Program_Error is raised executing default
3181 -- implementation of the Input attribute of an unchecked union
3182 -- type if the type lacks default discriminant values.
3184 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3185 and then No
(Discriminant_Constraint
(U_Type
))
3188 Make_Raise_Program_Error
(Loc
,
3189 Reason
=> PE_Unchecked_Union_Restriction
));
3194 -- Build the type's Input function, passing the subtype rather
3195 -- than its base type, because checks are needed in the case of
3196 -- constrained discriminants (see Ada 2012 AI05-0192).
3198 Build_Record_Or_Elementary_Input_Function
3199 (Loc
, U_Type
, Decl
, Fname
);
3200 Insert_Action
(N
, Decl
);
3202 if Nkind
(Parent
(N
)) = N_Object_Declaration
3203 and then Is_Record_Type
(U_Type
)
3205 -- The stream function may contain calls to user-defined
3206 -- Read procedures for individual components.
3213 Comp
:= First_Component
(U_Type
);
3214 while Present
(Comp
) loop
3216 Find_Stream_Subprogram
3217 (Etype
(Comp
), TSS_Stream_Read
);
3219 if Present
(Func
) then
3220 Freeze_Stream_Subprogram
(Func
);
3223 Next_Component
(Comp
);
3230 -- If we fall through, Fname is the function to be called. The result
3231 -- is obtained by calling the appropriate function, then converting
3232 -- the result. The conversion does a subtype check.
3235 Make_Function_Call
(Loc
,
3236 Name
=> New_Occurrence_Of
(Fname
, Loc
),
3237 Parameter_Associations
=> New_List
(
3238 Relocate_Node
(Strm
)));
3240 Set_Controlling_Argument
(Call
, Cntrl
);
3241 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
3242 Analyze_And_Resolve
(N
, P_Type
);
3244 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
3245 Freeze_Stream_Subprogram
(Fname
);
3255 -- inttype'Fixed_Value (fixed-value)
3259 -- inttype(integer-value))
3261 -- we do all the required analysis of the conversion here, because we do
3262 -- not want this to go through the fixed-point conversion circuits. Note
3263 -- that the back end always treats fixed-point as equivalent to the
3264 -- corresponding integer type anyway.
3266 when Attribute_Integer_Value
=> Integer_Value
:
3269 Make_Type_Conversion
(Loc
,
3270 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
3271 Expression
=> Relocate_Node
(First
(Exprs
))));
3272 Set_Etype
(N
, Entity
(Pref
));
3275 -- Note: it might appear that a properly analyzed unchecked conversion
3276 -- would be just fine here, but that's not the case, since the full
3277 -- range checks performed by the following call are critical!
3279 Apply_Type_Conversion_Checks
(N
);
3286 when Attribute_Invalid_Value
=>
3287 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
3293 when Attribute_Last
=>
3295 -- If the prefix type is a constrained packed array type which
3296 -- already has a Packed_Array_Type representation defined, then
3297 -- replace this attribute with a direct reference to 'Last of the
3298 -- appropriate index subtype (since otherwise the back end will try
3299 -- to give us the value of 'Last for this implementation type).
3301 if Is_Constrained_Packed_Array
(Ptyp
) then
3303 Make_Attribute_Reference
(Loc
,
3304 Attribute_Name
=> Name_Last
,
3305 Prefix
=> New_Reference_To
(Get_Index_Subtype
(N
), Loc
)));
3306 Analyze_And_Resolve
(N
, Typ
);
3308 elsif Is_Access_Type
(Ptyp
) then
3309 Apply_Access_Check
(N
);
3316 -- We compute this if a component clause was present, otherwise we leave
3317 -- the computation up to the back end, since we don't know what layout
3320 when Attribute_Last_Bit
=> Last_Bit_Attr
: declare
3321 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3324 -- In Ada 2005 (or later) if we have the non-default bit order, then
3325 -- we return the original value as given in the component clause
3326 -- (RM 2005 13.5.2(3/2)).
3328 if Present
(Component_Clause
(CE
))
3329 and then Ada_Version
>= Ada_2005
3330 and then Reverse_Bit_Order
(Scope
(CE
))
3333 Make_Integer_Literal
(Loc
,
3334 Intval
=> Expr_Value
(Last_Bit
(Component_Clause
(CE
)))));
3335 Analyze_And_Resolve
(N
, Typ
);
3337 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3338 -- rewrite with normalized value if we know it statically.
3340 elsif Known_Static_Component_Bit_Offset
(CE
)
3341 and then Known_Static_Esize
(CE
)
3344 Make_Integer_Literal
(Loc
,
3345 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
3347 Analyze_And_Resolve
(N
, Typ
);
3349 -- Otherwise leave to back end, just apply universal integer checks
3352 Apply_Universal_Integer_Attribute_Checks
(N
);
3360 -- Transforms 'Leading_Part into a call to the floating-point attribute
3361 -- function Leading_Part in Fat_xxx (where xxx is the root type)
3363 -- Note: strictly, we should generate special case code to deal with
3364 -- absurdly large positive arguments (greater than Integer'Last), which
3365 -- result in returning the first argument unchanged, but it hardly seems
3366 -- worth the effort. We raise constraint error for absurdly negative
3367 -- arguments which is fine.
3369 when Attribute_Leading_Part
=>
3370 Expand_Fpt_Attribute_RI
(N
);
3376 when Attribute_Length
=> Length
: declare
3381 -- Processing for packed array types
3383 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
3384 Ityp
:= Get_Index_Subtype
(N
);
3386 -- If the index type, Ityp, is an enumeration type with holes,
3387 -- then we calculate X'Length explicitly using
3390 -- (0, Ityp'Pos (X'Last (N)) -
3391 -- Ityp'Pos (X'First (N)) + 1);
3393 -- Since the bounds in the template are the representation values
3394 -- and the back end would get the wrong value.
3396 if Is_Enumeration_Type
(Ityp
)
3397 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
3402 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
3406 Make_Attribute_Reference
(Loc
,
3407 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3408 Attribute_Name
=> Name_Max
,
3409 Expressions
=> New_List
3410 (Make_Integer_Literal
(Loc
, 0),
3414 Make_Op_Subtract
(Loc
,
3416 Make_Attribute_Reference
(Loc
,
3417 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3418 Attribute_Name
=> Name_Pos
,
3420 Expressions
=> New_List
(
3421 Make_Attribute_Reference
(Loc
,
3422 Prefix
=> Duplicate_Subexpr
(Pref
),
3423 Attribute_Name
=> Name_Last
,
3424 Expressions
=> New_List
(
3425 Make_Integer_Literal
(Loc
, Xnum
))))),
3428 Make_Attribute_Reference
(Loc
,
3429 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
3430 Attribute_Name
=> Name_Pos
,
3432 Expressions
=> New_List
(
3433 Make_Attribute_Reference
(Loc
,
3435 Duplicate_Subexpr_No_Checks
(Pref
),
3436 Attribute_Name
=> Name_First
,
3437 Expressions
=> New_List
(
3438 Make_Integer_Literal
(Loc
, Xnum
)))))),
3440 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
3442 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
3445 -- If the prefix type is a constrained packed array type which
3446 -- already has a Packed_Array_Type representation defined, then
3447 -- replace this attribute with a direct reference to 'Range_Length
3448 -- of the appropriate index subtype (since otherwise the back end
3449 -- will try to give us the value of 'Length for this
3450 -- implementation type).
3452 elsif Is_Constrained
(Ptyp
) then
3454 Make_Attribute_Reference
(Loc
,
3455 Attribute_Name
=> Name_Range_Length
,
3456 Prefix
=> New_Reference_To
(Ityp
, Loc
)));
3457 Analyze_And_Resolve
(N
, Typ
);
3462 elsif Is_Access_Type
(Ptyp
) then
3463 Apply_Access_Check
(N
);
3465 -- If the designated type is a packed array type, then we convert
3466 -- the reference to:
3469 -- xtyp'Pos (Pref'Last (Expr)) -
3470 -- xtyp'Pos (Pref'First (Expr)));
3472 -- This is a bit complex, but it is the easiest thing to do that
3473 -- works in all cases including enum types with holes xtyp here
3474 -- is the appropriate index type.
3477 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
3481 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
3482 Xtyp
:= Get_Index_Subtype
(N
);
3485 Make_Attribute_Reference
(Loc
,
3486 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
3487 Attribute_Name
=> Name_Max
,
3488 Expressions
=> New_List
(
3489 Make_Integer_Literal
(Loc
, 0),
3492 Make_Integer_Literal
(Loc
, 1),
3493 Make_Op_Subtract
(Loc
,
3495 Make_Attribute_Reference
(Loc
,
3496 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
3497 Attribute_Name
=> Name_Pos
,
3498 Expressions
=> New_List
(
3499 Make_Attribute_Reference
(Loc
,
3500 Prefix
=> Duplicate_Subexpr
(Pref
),
3501 Attribute_Name
=> Name_Last
,
3503 New_Copy_List
(Exprs
)))),
3506 Make_Attribute_Reference
(Loc
,
3507 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
3508 Attribute_Name
=> Name_Pos
,
3509 Expressions
=> New_List
(
3510 Make_Attribute_Reference
(Loc
,
3512 Duplicate_Subexpr_No_Checks
(Pref
),
3513 Attribute_Name
=> Name_First
,
3515 New_Copy_List
(Exprs
)))))))));
3517 Analyze_And_Resolve
(N
, Typ
);
3521 -- Otherwise leave it to the back end
3524 Apply_Universal_Integer_Attribute_Checks
(N
);
3528 -- Attribute Loop_Entry is replaced with a reference to a constant value
3529 -- which captures the prefix at the entry point of the related loop. The
3530 -- loop itself may be transformed into a conditional block.
3532 when Attribute_Loop_Entry
=>
3533 Expand_Loop_Entry_Attribute
(N
);
3539 -- Transforms 'Machine into a call to the floating-point attribute
3540 -- function Machine in Fat_xxx (where xxx is the root type)
3542 when Attribute_Machine
=>
3543 Expand_Fpt_Attribute_R
(N
);
3545 ----------------------
3546 -- Machine_Rounding --
3547 ----------------------
3549 -- Transforms 'Machine_Rounding into a call to the floating-point
3550 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
3551 -- type). Expansion is avoided for cases the back end can handle
3554 when Attribute_Machine_Rounding
=>
3555 if not Is_Inline_Floating_Point_Attribute
(N
) then
3556 Expand_Fpt_Attribute_R
(N
);
3563 -- Machine_Size is equivalent to Object_Size, so transform it into
3564 -- Object_Size and that way the back end never sees Machine_Size.
3566 when Attribute_Machine_Size
=>
3568 Make_Attribute_Reference
(Loc
,
3569 Prefix
=> Prefix
(N
),
3570 Attribute_Name
=> Name_Object_Size
));
3572 Analyze_And_Resolve
(N
, Typ
);
3578 -- The only case that can get this far is the dynamic case of the old
3579 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
3586 -- ityp (System.Mantissa.Mantissa_Value
3587 -- (Integer'Integer_Value (typ'First),
3588 -- Integer'Integer_Value (typ'Last)));
3590 when Attribute_Mantissa
=> Mantissa
: begin
3593 Make_Function_Call
(Loc
,
3594 Name
=> New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
3596 Parameter_Associations
=> New_List
(
3598 Make_Attribute_Reference
(Loc
,
3599 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
3600 Attribute_Name
=> Name_Integer_Value
,
3601 Expressions
=> New_List
(
3603 Make_Attribute_Reference
(Loc
,
3604 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3605 Attribute_Name
=> Name_First
))),
3607 Make_Attribute_Reference
(Loc
,
3608 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
3609 Attribute_Name
=> Name_Integer_Value
,
3610 Expressions
=> New_List
(
3612 Make_Attribute_Reference
(Loc
,
3613 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3614 Attribute_Name
=> Name_Last
)))))));
3616 Analyze_And_Resolve
(N
, Typ
);
3619 ----------------------------------
3620 -- Max_Size_In_Storage_Elements --
3621 ----------------------------------
3623 when Attribute_Max_Size_In_Storage_Elements
=> declare
3624 Typ
: constant Entity_Id
:= Etype
(N
);
3627 Conversion_Added
: Boolean := False;
3628 -- A flag which tracks whether the original attribute has been
3629 -- wrapped inside a type conversion.
3632 Apply_Universal_Integer_Attribute_Checks
(N
);
3634 -- The universal integer check may sometimes add a type conversion,
3635 -- retrieve the original attribute reference from the expression.
3638 if Nkind
(Attr
) = N_Type_Conversion
then
3639 Attr
:= Expression
(Attr
);
3640 Conversion_Added
:= True;
3643 -- Heap-allocated controlled objects contain two extra pointers which
3644 -- are not part of the actual type. Transform the attribute reference
3645 -- into a runtime expression to add the size of the hidden header.
3647 -- Do not perform this expansion on .NET/JVM targets because the
3648 -- two pointers are already present in the type.
3650 if VM_Target
= No_VM
3651 and then Nkind
(Attr
) = N_Attribute_Reference
3652 and then Needs_Finalization
(Ptyp
)
3653 and then not Header_Size_Added
(Attr
)
3655 Set_Header_Size_Added
(Attr
);
3658 -- P'Max_Size_In_Storage_Elements +
3659 -- Universal_Integer
3660 -- (Header_Size_With_Padding (Ptyp'Alignment))
3664 Left_Opnd
=> Relocate_Node
(Attr
),
3666 Convert_To
(Universal_Integer
,
3667 Make_Function_Call
(Loc
,
3670 (RTE
(RE_Header_Size_With_Padding
), Loc
),
3672 Parameter_Associations
=> New_List
(
3673 Make_Attribute_Reference
(Loc
,
3675 New_Reference_To
(Ptyp
, Loc
),
3676 Attribute_Name
=> Name_Alignment
))))));
3678 -- Add a conversion to the target type
3680 if not Conversion_Added
then
3682 Make_Type_Conversion
(Loc
,
3683 Subtype_Mark
=> New_Reference_To
(Typ
, Loc
),
3684 Expression
=> Relocate_Node
(Attr
)));
3692 --------------------
3693 -- Mechanism_Code --
3694 --------------------
3696 when Attribute_Mechanism_Code
=>
3698 -- We must replace the prefix in the renamed case
3700 if Is_Entity_Name
(Pref
)
3701 and then Present
(Alias
(Entity
(Pref
)))
3703 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
3710 when Attribute_Mod
=> Mod_Case
: declare
3711 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
3712 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
3713 Modv
: constant Uint
:= Modulus
(Btyp
);
3717 -- This is not so simple. The issue is what type to use for the
3718 -- computation of the modular value.
3720 -- The easy case is when the modulus value is within the bounds
3721 -- of the signed integer type of the argument. In this case we can
3722 -- just do the computation in that signed integer type, and then
3723 -- do an ordinary conversion to the target type.
3725 if Modv
<= Expr_Value
(Hi
) then
3730 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
3732 -- Here we know that the modulus is larger than type'Last of the
3733 -- integer type. There are two cases to consider:
3735 -- a) The integer value is non-negative. In this case, it is
3736 -- returned as the result (since it is less than the modulus).
3738 -- b) The integer value is negative. In this case, we know that the
3739 -- result is modulus + value, where the value might be as small as
3740 -- -modulus. The trouble is what type do we use to do the subtract.
3741 -- No type will do, since modulus can be as big as 2**64, and no
3742 -- integer type accommodates this value. Let's do bit of algebra
3745 -- = modulus - (-value)
3746 -- = (modulus - 1) - (-value - 1)
3748 -- Now modulus - 1 is certainly in range of the modular type.
3749 -- -value is in the range 1 .. modulus, so -value -1 is in the
3750 -- range 0 .. modulus-1 which is in range of the modular type.
3751 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
3752 -- which we can compute using the integer base type.
3754 -- Once this is done we analyze the if expression without range
3755 -- checks, because we know everything is in range, and we want
3756 -- to prevent spurious warnings on either branch.
3760 Make_If_Expression
(Loc
,
3761 Expressions
=> New_List
(
3763 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
3764 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
3767 Duplicate_Subexpr_No_Checks
(Arg
)),
3769 Make_Op_Subtract
(Loc
,
3771 Make_Integer_Literal
(Loc
,
3772 Intval
=> Modv
- 1),
3778 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
3780 Make_Integer_Literal
(Loc
,
3781 Intval
=> 1))))))));
3785 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
3792 -- Transforms 'Model into a call to the floating-point attribute
3793 -- function Model in Fat_xxx (where xxx is the root type)
3795 when Attribute_Model
=>
3796 Expand_Fpt_Attribute_R
(N
);
3802 -- The processing for Object_Size shares the processing for Size
3808 when Attribute_Old
=> Old
: declare
3809 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Pref
);
3814 -- If assertions are disabled, no need to create the declaration
3815 -- that preserves the value.
3817 if not Assertions_Enabled
then
3821 -- Find the nearest subprogram body, ignoring _Preconditions
3825 Subp
:= Parent
(Subp
);
3826 exit when Nkind
(Subp
) = N_Subprogram_Body
3827 and then Chars
(Defining_Entity
(Subp
)) /= Name_uPostconditions
;
3830 -- Insert the initialized object declaration at the start of the
3831 -- subprogram's declarations.
3834 Make_Object_Declaration
(Loc
,
3835 Defining_Identifier
=> Tnn
,
3836 Constant_Present
=> True,
3837 Object_Definition
=> New_Occurrence_Of
(Etype
(N
), Loc
),
3838 Expression
=> Pref
);
3840 -- Push the subprogram's scope, so that the object will be analyzed
3841 -- in that context (rather than the context of the Precondition
3842 -- subprogram) and will have its Scope set properly.
3844 if Present
(Corresponding_Spec
(Subp
)) then
3845 Push_Scope
(Corresponding_Spec
(Subp
));
3847 Push_Scope
(Defining_Entity
(Subp
));
3850 if Is_Empty_List
(Declarations
(Subp
)) then
3851 Set_Declarations
(Subp
, New_List
(Asn_Stm
));
3854 Insert_Action
(First
(Declarations
(Subp
)), Asn_Stm
);
3859 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
3862 ----------------------
3863 -- Overlaps_Storage --
3864 ----------------------
3866 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
3867 Loc
: constant Source_Ptr
:= Sloc
(N
);
3869 X
: constant Node_Id
:= Prefix
(N
);
3870 Y
: constant Node_Id
:= First
(Expressions
(N
));
3873 X_Addr
, Y_Addr
: Node_Id
;
3874 -- the expressions for their integer addresses
3876 X_Size
, Y_Size
: Node_Id
;
3877 -- the expressions for their sizes
3882 -- Attribute expands into:
3884 -- if X'Address < Y'address then
3885 -- (X'address + X'Size - 1) >= Y'address
3887 -- (Y'address + Y'size - 1) >= X'Address
3890 -- with the proper address operations. We convert addresses to
3891 -- integer addresses to use predefined arithmetic. The size is
3892 -- expressed in storage units.
3895 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
3896 Make_Attribute_Reference
(Loc
,
3897 Attribute_Name
=> Name_Address
,
3898 Prefix
=> New_Copy_Tree
(X
)));
3901 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
3902 Make_Attribute_Reference
(Loc
,
3903 Attribute_Name
=> Name_Address
,
3904 Prefix
=> New_Copy_Tree
(Y
)));
3907 Make_Op_Divide
(Loc
,
3909 Make_Attribute_Reference
(Loc
,
3910 Attribute_Name
=> Name_Size
,
3911 Prefix
=> New_Copy_Tree
(X
)),
3913 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
3916 Make_Op_Divide
(Loc
,
3918 Make_Attribute_Reference
(Loc
,
3919 Attribute_Name
=> Name_Size
,
3920 Prefix
=> New_Copy_Tree
(Y
)),
3922 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
3926 Left_Opnd
=> X_Addr
,
3927 Right_Opnd
=> Y_Addr
);
3930 Make_If_Expression
(Loc
,
3937 Left_Opnd
=> X_Addr
,
3939 Make_Op_Subtract
(Loc
,
3940 Left_Opnd
=> X_Size
,
3941 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
3942 Right_Opnd
=> Y_Addr
),
3946 Left_Opnd
=> Y_Addr
,
3948 Make_Op_Subtract
(Loc
,
3949 Left_Opnd
=> Y_Size
,
3950 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
3951 Right_Opnd
=> X_Addr
))));
3953 Analyze_And_Resolve
(N
, Standard_Boolean
);
3954 end Overlaps_Storage
;
3960 when Attribute_Output
=> Output
: declare
3961 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3962 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3970 -- If no underlying type, we have an error that will be diagnosed
3971 -- elsewhere, so here we just completely ignore the expansion.
3977 -- If TSS for Output is present, just call it
3979 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
3981 if Present
(Pname
) then
3985 -- If there is a Stream_Convert pragma, use it, we rewrite
3987 -- sourcetyp'Output (stream, Item)
3991 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3993 -- where strmwrite is the given Write function that converts an
3994 -- argument of type sourcetyp or a type acctyp, from which it is
3995 -- derived to type strmtyp. The conversion to acttyp is required
3996 -- for the derived case.
3998 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4000 if Present
(Prag
) then
4002 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
4003 Wfunc
:= Entity
(Expression
(Arg3
));
4006 Make_Attribute_Reference
(Loc
,
4007 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
4008 Attribute_Name
=> Name_Output
,
4009 Expressions
=> New_List
(
4010 Relocate_Node
(First
(Exprs
)),
4011 Make_Function_Call
(Loc
,
4012 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
4013 Parameter_Associations
=> New_List
(
4014 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
4015 Relocate_Node
(Next
(First
(Exprs
)))))))));
4020 -- For elementary types, we call the W_xxx routine directly.
4021 -- Note that the effect of Write and Output is identical for
4022 -- the case of an elementary type, since there are no
4023 -- discriminants or bounds.
4025 elsif Is_Elementary_Type
(U_Type
) then
4027 -- A special case arises if we have a defined _Write routine,
4028 -- since in this case we are required to call this routine.
4030 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Write
)) then
4031 Build_Record_Or_Elementary_Output_Procedure
4032 (Loc
, U_Type
, Decl
, Pname
);
4033 Insert_Action
(N
, Decl
);
4035 -- For normal cases, we call the W_xxx routine directly
4038 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
4045 elsif Is_Array_Type
(U_Type
) then
4046 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
4047 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4049 -- Class-wide case, first output external tag, then dispatch
4050 -- to the appropriate primitive Output function (RM 13.13.2(31)).
4052 elsif Is_Class_Wide_Type
(P_Type
) then
4054 -- No need to do anything else compiling under restriction
4055 -- No_Dispatching_Calls. During the semantic analysis we
4056 -- already notified such violation.
4058 if Restriction_Active
(No_Dispatching_Calls
) then
4063 Strm
: constant Node_Id
:= First
(Exprs
);
4064 Item
: constant Node_Id
:= Next
(Strm
);
4067 -- Ada 2005 (AI-344): Check that the accessibility level
4068 -- of the type of the output object is not deeper than
4069 -- that of the attribute's prefix type.
4071 -- if Get_Access_Level (Item'Tag)
4072 -- /= Get_Access_Level (P_Type'Tag)
4077 -- String'Output (Strm, External_Tag (Item'Tag));
4079 -- We cannot figure out a practical way to implement this
4080 -- accessibility check on virtual machines, so we omit it.
4082 if Ada_Version
>= Ada_2005
4083 and then Tagged_Type_Expansion
4086 Make_Implicit_If_Statement
(N
,
4090 Build_Get_Access_Level
(Loc
,
4091 Make_Attribute_Reference
(Loc
,
4094 Duplicate_Subexpr
(Item
,
4096 Attribute_Name
=> Name_Tag
)),
4099 Make_Integer_Literal
(Loc
,
4100 Type_Access_Level
(P_Type
))),
4103 New_List
(Make_Raise_Statement
(Loc
,
4105 RTE
(RE_Tag_Error
), Loc
)))));
4109 Make_Attribute_Reference
(Loc
,
4110 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
4111 Attribute_Name
=> Name_Output
,
4112 Expressions
=> New_List
(
4113 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
4114 Make_Function_Call
(Loc
,
4116 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
4117 Parameter_Associations
=> New_List
(
4118 Make_Attribute_Reference
(Loc
,
4121 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
4122 Attribute_Name
=> Name_Tag
))))));
4125 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4127 -- Tagged type case, use the primitive Output function
4129 elsif Is_Tagged_Type
(U_Type
) then
4130 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
4132 -- All other record type cases, including protected records.
4133 -- The latter only arise for expander generated code for
4134 -- handling shared passive partition access.
4138 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4140 -- Ada 2005 (AI-216): Program_Error is raised when executing
4141 -- the default implementation of the Output attribute of an
4142 -- unchecked union type if the type lacks default discriminant
4145 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4146 and then No
(Discriminant_Constraint
(U_Type
))
4149 Make_Raise_Program_Error
(Loc
,
4150 Reason
=> PE_Unchecked_Union_Restriction
));
4155 Build_Record_Or_Elementary_Output_Procedure
4156 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
4157 Insert_Action
(N
, Decl
);
4161 -- If we fall through, Pname is the name of the procedure to call
4163 Rewrite_Stream_Proc_Call
(Pname
);
4170 -- For enumeration types with a standard representation, Pos is
4171 -- handled by the back end.
4173 -- For enumeration types, with a non-standard representation we generate
4174 -- a call to the _Rep_To_Pos function created when the type was frozen.
4175 -- The call has the form
4177 -- _rep_to_pos (expr, flag)
4179 -- The parameter flag is True if range checks are enabled, causing
4180 -- Program_Error to be raised if the expression has an invalid
4181 -- representation, and False if range checks are suppressed.
4183 -- For integer types, Pos is equivalent to a simple integer
4184 -- conversion and we rewrite it as such
4186 when Attribute_Pos
=> Pos
:
4188 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
4191 -- Deal with zero/non-zero boolean values
4193 if Is_Boolean_Type
(Etyp
) then
4194 Adjust_Condition
(First
(Exprs
));
4195 Etyp
:= Standard_Boolean
;
4196 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
4199 -- Case of enumeration type
4201 if Is_Enumeration_Type
(Etyp
) then
4203 -- Non-standard enumeration type (generate call)
4205 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
4206 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
4209 Make_Function_Call
(Loc
,
4211 New_Reference_To
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4212 Parameter_Associations
=> Exprs
)));
4214 Analyze_And_Resolve
(N
, Typ
);
4216 -- Standard enumeration type (do universal integer check)
4219 Apply_Universal_Integer_Attribute_Checks
(N
);
4222 -- Deal with integer types (replace by conversion)
4224 elsif Is_Integer_Type
(Etyp
) then
4225 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
4226 Analyze_And_Resolve
(N
, Typ
);
4235 -- We compute this if a component clause was present, otherwise we leave
4236 -- the computation up to the back end, since we don't know what layout
4239 when Attribute_Position
=> Position_Attr
:
4241 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4244 if Present
(Component_Clause
(CE
)) then
4246 -- In Ada 2005 (or later) if we have the non-default bit order,
4247 -- then we return the original value as given in the component
4248 -- clause (RM 2005 13.5.2(2/2)).
4250 if Ada_Version
>= Ada_2005
4251 and then Reverse_Bit_Order
(Scope
(CE
))
4254 Make_Integer_Literal
(Loc
,
4255 Intval
=> Expr_Value
(Position
(Component_Clause
(CE
)))));
4257 -- Otherwise (Ada 83 or 95, or default bit order specified in
4258 -- later Ada version), return the normalized value.
4262 Make_Integer_Literal
(Loc
,
4263 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
4266 Analyze_And_Resolve
(N
, Typ
);
4268 -- If back end is doing things, just apply universal integer checks
4271 Apply_Universal_Integer_Attribute_Checks
(N
);
4279 -- 1. Deal with enumeration types with holes
4280 -- 2. For floating-point, generate call to attribute function
4281 -- 3. For other cases, deal with constraint checking
4283 when Attribute_Pred
=> Pred
:
4285 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
4289 -- For enumeration types with non-standard representations, we
4290 -- expand typ'Pred (x) into
4292 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
4294 -- If the representation is contiguous, we compute instead
4295 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
4296 -- The conversion function Enum_Pos_To_Rep is defined on the
4297 -- base type, not the subtype, so we have to use the base type
4298 -- explicitly for this and other enumeration attributes.
4300 if Is_Enumeration_Type
(Ptyp
)
4301 and then Present
(Enum_Pos_To_Rep
(Etyp
))
4303 if Has_Contiguous_Rep
(Etyp
) then
4305 Unchecked_Convert_To
(Ptyp
,
4308 Make_Integer_Literal
(Loc
,
4309 Enumeration_Rep
(First_Literal
(Ptyp
))),
4311 Make_Function_Call
(Loc
,
4314 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4316 Parameter_Associations
=>
4318 Unchecked_Convert_To
(Ptyp
,
4319 Make_Op_Subtract
(Loc
,
4321 Unchecked_Convert_To
(Standard_Integer
,
4322 Relocate_Node
(First
(Exprs
))),
4324 Make_Integer_Literal
(Loc
, 1))),
4325 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
4328 -- Add Boolean parameter True, to request program errror if
4329 -- we have a bad representation on our hands. If checks are
4330 -- suppressed, then add False instead
4332 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
4334 Make_Indexed_Component
(Loc
,
4337 (Enum_Pos_To_Rep
(Etyp
), Loc
),
4338 Expressions
=> New_List
(
4339 Make_Op_Subtract
(Loc
,
4341 Make_Function_Call
(Loc
,
4344 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4345 Parameter_Associations
=> Exprs
),
4346 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4349 Analyze_And_Resolve
(N
, Typ
);
4351 -- For floating-point, we transform 'Pred into a call to the Pred
4352 -- floating-point attribute function in Fat_xxx (xxx is root type)
4354 elsif Is_Floating_Point_Type
(Ptyp
) then
4355 Expand_Fpt_Attribute_R
(N
);
4356 Analyze_And_Resolve
(N
, Typ
);
4358 -- For modular types, nothing to do (no overflow, since wraps)
4360 elsif Is_Modular_Integer_Type
(Ptyp
) then
4363 -- For other types, if argument is marked as needing a range check or
4364 -- overflow checking is enabled, we must generate a check.
4366 elsif not Overflow_Checks_Suppressed
(Ptyp
)
4367 or else Do_Range_Check
(First
(Exprs
))
4369 Set_Do_Range_Check
(First
(Exprs
), False);
4370 Expand_Pred_Succ
(N
);
4378 -- Ada 2005 (AI-327): Dynamic ceiling priorities
4380 -- We rewrite X'Priority as the following run-time call:
4382 -- Get_Ceiling (X._Object)
4384 -- Note that although X'Priority is notionally an object, it is quite
4385 -- deliberately not defined as an aliased object in the RM. This means
4386 -- that it works fine to rewrite it as a call, without having to worry
4387 -- about complications that would other arise from X'Priority'Access,
4388 -- which is illegal, because of the lack of aliasing.
4390 when Attribute_Priority
=>
4393 Conctyp
: Entity_Id
;
4394 Object_Parm
: Node_Id
;
4396 RT_Subprg_Name
: Node_Id
;
4399 -- Look for the enclosing concurrent type
4401 Conctyp
:= Current_Scope
;
4402 while not Is_Concurrent_Type
(Conctyp
) loop
4403 Conctyp
:= Scope
(Conctyp
);
4406 pragma Assert
(Is_Protected_Type
(Conctyp
));
4408 -- Generate the actual of the call
4410 Subprg
:= Current_Scope
;
4411 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
4412 Subprg
:= Scope
(Subprg
);
4415 -- Use of 'Priority inside protected entries and barriers (in
4416 -- both cases the type of the first formal of their expanded
4417 -- subprogram is Address)
4419 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
)))
4423 New_Itype
: Entity_Id
;
4426 -- In the expansion of protected entries the type of the
4427 -- first formal of the Protected_Body_Subprogram is an
4428 -- Address. In order to reference the _object component
4431 -- type T is access p__ptTV;
4434 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
4435 Set_Etype
(New_Itype
, New_Itype
);
4436 Set_Directly_Designated_Type
(New_Itype
,
4437 Corresponding_Record_Type
(Conctyp
));
4438 Freeze_Itype
(New_Itype
, N
);
4441 -- T!(O)._object'unchecked_access
4444 Make_Attribute_Reference
(Loc
,
4446 Make_Selected_Component
(Loc
,
4448 Unchecked_Convert_To
(New_Itype
,
4451 (Protected_Body_Subprogram
(Subprg
)),
4454 Make_Identifier
(Loc
, Name_uObject
)),
4455 Attribute_Name
=> Name_Unchecked_Access
);
4458 -- Use of 'Priority inside a protected subprogram
4462 Make_Attribute_Reference
(Loc
,
4464 Make_Selected_Component
(Loc
,
4465 Prefix
=> New_Reference_To
4467 (Protected_Body_Subprogram
(Subprg
)),
4469 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
4470 Attribute_Name
=> Name_Unchecked_Access
);
4473 -- Select the appropriate run-time subprogram
4475 if Number_Entries
(Conctyp
) = 0 then
4477 New_Reference_To
(RTE
(RE_Get_Ceiling
), Loc
);
4480 New_Reference_To
(RTE
(RO_PE_Get_Ceiling
), Loc
);
4484 Make_Function_Call
(Loc
,
4485 Name
=> RT_Subprg_Name
,
4486 Parameter_Associations
=> New_List
(Object_Parm
));
4490 -- Avoid the generation of extra checks on the pointer to the
4491 -- protected object.
4493 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
4500 when Attribute_Range_Length
=> Range_Length
: begin
4502 -- The only special processing required is for the case where
4503 -- Range_Length is applied to an enumeration type with holes.
4504 -- In this case we transform
4510 -- X'Pos (X'Last) - X'Pos (X'First) + 1
4512 -- So that the result reflects the proper Pos values instead
4513 -- of the underlying representations.
4515 if Is_Enumeration_Type
(Ptyp
)
4516 and then Has_Non_Standard_Rep
(Ptyp
)
4521 Make_Op_Subtract
(Loc
,
4523 Make_Attribute_Reference
(Loc
,
4524 Attribute_Name
=> Name_Pos
,
4525 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4526 Expressions
=> New_List
(
4527 Make_Attribute_Reference
(Loc
,
4528 Attribute_Name
=> Name_Last
,
4529 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
)))),
4532 Make_Attribute_Reference
(Loc
,
4533 Attribute_Name
=> Name_Pos
,
4534 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4535 Expressions
=> New_List
(
4536 Make_Attribute_Reference
(Loc
,
4537 Attribute_Name
=> Name_First
,
4538 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
))))),
4540 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
4542 Analyze_And_Resolve
(N
, Typ
);
4544 -- For all other cases, the attribute is handled by the back end, but
4545 -- we need to deal with the case of the range check on a universal
4549 Apply_Universal_Integer_Attribute_Checks
(N
);
4557 when Attribute_Read
=> Read
: declare
4558 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4559 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
4560 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4570 -- If no underlying type, we have an error that will be diagnosed
4571 -- elsewhere, so here we just completely ignore the expansion.
4577 -- The simple case, if there is a TSS for Read, just call it
4579 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
4581 if Present
(Pname
) then
4585 -- If there is a Stream_Convert pragma, use it, we rewrite
4587 -- sourcetyp'Read (stream, Item)
4591 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
4593 -- where strmread is the given Read function that converts an
4594 -- argument of type strmtyp to type sourcetyp or a type from which
4595 -- it is derived. The conversion to sourcetyp is required in the
4598 -- A special case arises if Item is a type conversion in which
4599 -- case, we have to expand to:
4601 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
4603 -- where Itemx is the expression of the type conversion (i.e.
4604 -- the actual object), and typex is the type of Itemx.
4606 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4608 if Present
(Prag
) then
4609 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4610 Rfunc
:= Entity
(Expression
(Arg2
));
4611 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
4613 OK_Convert_To
(B_Type
,
4614 Make_Function_Call
(Loc
,
4615 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4616 Parameter_Associations
=> New_List
(
4617 Make_Attribute_Reference
(Loc
,
4620 (Etype
(First_Formal
(Rfunc
)), Loc
),
4621 Attribute_Name
=> Name_Input
,
4622 Expressions
=> New_List
(
4623 Relocate_Node
(First
(Exprs
)))))));
4625 if Nkind
(Lhs
) = N_Type_Conversion
then
4626 Lhs
:= Expression
(Lhs
);
4627 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
4631 Make_Assignment_Statement
(Loc
,
4633 Expression
=> Rhs
));
4634 Set_Assignment_OK
(Lhs
);
4638 -- For elementary types, we call the I_xxx routine using the first
4639 -- parameter and then assign the result into the second parameter.
4640 -- We set Assignment_OK to deal with the conversion case.
4642 elsif Is_Elementary_Type
(U_Type
) then
4648 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
4649 Rhs
:= Build_Elementary_Input_Call
(N
);
4651 if Nkind
(Lhs
) = N_Type_Conversion
then
4652 Lhs
:= Expression
(Lhs
);
4653 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
4656 Set_Assignment_OK
(Lhs
);
4659 Make_Assignment_Statement
(Loc
,
4661 Expression
=> Rhs
));
4669 elsif Is_Array_Type
(U_Type
) then
4670 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
4671 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
4673 -- Tagged type case, use the primitive Read function. Note that
4674 -- this will dispatch in the class-wide case which is what we want
4676 elsif Is_Tagged_Type
(U_Type
) then
4677 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
4679 -- All other record type cases, including protected records. The
4680 -- latter only arise for expander generated code for handling
4681 -- shared passive partition access.
4685 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4687 -- Ada 2005 (AI-216): Program_Error is raised when executing
4688 -- the default implementation of the Read attribute of an
4689 -- Unchecked_Union type.
4691 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
4693 Make_Raise_Program_Error
(Loc
,
4694 Reason
=> PE_Unchecked_Union_Restriction
));
4697 if Has_Discriminants
(U_Type
)
4699 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
4701 Build_Mutable_Record_Read_Procedure
4702 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
4704 Build_Record_Read_Procedure
4705 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
4708 -- Suppress checks, uninitialized or otherwise invalid
4709 -- data does not cause constraint errors to be raised for
4710 -- a complete record read.
4712 Insert_Action
(N
, Decl
, All_Checks
);
4716 Rewrite_Stream_Proc_Call
(Pname
);
4723 -- Ref is identical to To_Address, see To_Address for processing
4729 -- Transforms 'Remainder into a call to the floating-point attribute
4730 -- function Remainder in Fat_xxx (where xxx is the root type)
4732 when Attribute_Remainder
=>
4733 Expand_Fpt_Attribute_RR
(N
);
4739 -- Transform 'Result into reference to _Result formal. At the point
4740 -- where a legal 'Result attribute is expanded, we know that we are in
4741 -- the context of a _Postcondition function with a _Result parameter.
4743 when Attribute_Result
=>
4744 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
4745 Analyze_And_Resolve
(N
, Typ
);
4751 -- The handling of the Round attribute is quite delicate. The processing
4752 -- in Sem_Attr introduced a conversion to universal real, reflecting the
4753 -- semantics of Round, but we do not want anything to do with universal
4754 -- real at runtime, since this corresponds to using floating-point
4757 -- What we have now is that the Etype of the Round attribute correctly
4758 -- indicates the final result type. The operand of the Round is the
4759 -- conversion to universal real, described above, and the operand of
4760 -- this conversion is the actual operand of Round, which may be the
4761 -- special case of a fixed point multiplication or division (Etype =
4764 -- The exapander will expand first the operand of the conversion, then
4765 -- the conversion, and finally the round attribute itself, since we
4766 -- always work inside out. But we cannot simply process naively in this
4767 -- order. In the semantic world where universal fixed and real really
4768 -- exist and have infinite precision, there is no problem, but in the
4769 -- implementation world, where universal real is a floating-point type,
4770 -- we would get the wrong result.
4772 -- So the approach is as follows. First, when expanding a multiply or
4773 -- divide whose type is universal fixed, we do nothing at all, instead
4774 -- deferring the operation till later.
4776 -- The actual processing is done in Expand_N_Type_Conversion which
4777 -- handles the special case of Round by looking at its parent to see if
4778 -- it is a Round attribute, and if it is, handling the conversion (or
4779 -- its fixed multiply/divide child) in an appropriate manner.
4781 -- This means that by the time we get to expanding the Round attribute
4782 -- itself, the Round is nothing more than a type conversion (and will
4783 -- often be a null type conversion), so we just replace it with the
4784 -- appropriate conversion operation.
4786 when Attribute_Round
=>
4788 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
4789 Analyze_And_Resolve
(N
);
4795 -- Transforms 'Rounding into a call to the floating-point attribute
4796 -- function Rounding in Fat_xxx (where xxx is the root type)
4798 when Attribute_Rounding
=>
4799 Expand_Fpt_Attribute_R
(N
);
4805 when Attribute_Same_Storage
=> Same_Storage
: declare
4806 Loc
: constant Source_Ptr
:= Sloc
(N
);
4808 X
: constant Node_Id
:= Prefix
(N
);
4809 Y
: constant Node_Id
:= First
(Expressions
(N
));
4812 X_Addr
, Y_Addr
: Node_Id
;
4813 -- Rhe expressions for their addresses
4815 X_Size
, Y_Size
: Node_Id
;
4816 -- Rhe expressions for their sizes
4819 -- The attribute is expanded as:
4821 -- (X'address = Y'address)
4822 -- and then (X'Size = Y'Size)
4824 -- If both arguments have the same Etype the second conjunct can be
4828 Make_Attribute_Reference
(Loc
,
4829 Attribute_Name
=> Name_Address
,
4830 Prefix
=> New_Copy_Tree
(X
));
4833 Make_Attribute_Reference
(Loc
,
4834 Attribute_Name
=> Name_Address
,
4835 Prefix
=> New_Copy_Tree
(Y
));
4838 Make_Attribute_Reference
(Loc
,
4839 Attribute_Name
=> Name_Size
,
4840 Prefix
=> New_Copy_Tree
(X
));
4843 Make_Attribute_Reference
(Loc
,
4844 Attribute_Name
=> Name_Size
,
4845 Prefix
=> New_Copy_Tree
(Y
));
4847 if Etype
(X
) = Etype
(Y
) then
4850 Left_Opnd
=> X_Addr
,
4851 Right_Opnd
=> Y_Addr
)));
4857 Left_Opnd
=> X_Addr
,
4858 Right_Opnd
=> Y_Addr
),
4861 Left_Opnd
=> X_Size
,
4862 Right_Opnd
=> Y_Size
)));
4865 Analyze_And_Resolve
(N
, Standard_Boolean
);
4872 -- Transforms 'Scaling into a call to the floating-point attribute
4873 -- function Scaling in Fat_xxx (where xxx is the root type)
4875 when Attribute_Scaling
=>
4876 Expand_Fpt_Attribute_RI
(N
);
4878 -------------------------
4879 -- Simple_Storage_Pool --
4880 -------------------------
4882 when Attribute_Simple_Storage_Pool
=>
4884 Make_Type_Conversion
(Loc
,
4885 Subtype_Mark
=> New_Reference_To
(Etype
(N
), Loc
),
4886 Expression
=> New_Reference_To
(Entity
(N
), Loc
)));
4887 Analyze_And_Resolve
(N
, Typ
);
4893 when Attribute_Size |
4894 Attribute_Object_Size |
4895 Attribute_Value_Size |
4896 Attribute_VADS_Size
=> Size
:
4903 -- Processing for VADS_Size case. Note that this processing removes
4904 -- all traces of VADS_Size from the tree, and completes all required
4905 -- processing for VADS_Size by translating the attribute reference
4906 -- to an appropriate Size or Object_Size reference.
4908 if Id
= Attribute_VADS_Size
4909 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
4911 -- If the size is specified, then we simply use the specified
4912 -- size. This applies to both types and objects. The size of an
4913 -- object can be specified in the following ways:
4915 -- An explicit size object is given for an object
4916 -- A component size is specified for an indexed component
4917 -- A component clause is specified for a selected component
4918 -- The object is a component of a packed composite object
4920 -- If the size is specified, then VADS_Size of an object
4922 if (Is_Entity_Name
(Pref
)
4923 and then Present
(Size_Clause
(Entity
(Pref
))))
4925 (Nkind
(Pref
) = N_Component_Clause
4926 and then (Present
(Component_Clause
4927 (Entity
(Selector_Name
(Pref
))))
4928 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
4930 (Nkind
(Pref
) = N_Indexed_Component
4931 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
4932 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
4934 Set_Attribute_Name
(N
, Name_Size
);
4936 -- Otherwise if we have an object rather than a type, then the
4937 -- VADS_Size attribute applies to the type of the object, rather
4938 -- than the object itself. This is one of the respects in which
4939 -- VADS_Size differs from Size.
4942 if (not Is_Entity_Name
(Pref
)
4943 or else not Is_Type
(Entity
(Pref
)))
4944 and then (Is_Scalar_Type
(Ptyp
) or else Is_Constrained
(Ptyp
))
4946 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
4949 -- For a scalar type for which no size was explicitly given,
4950 -- VADS_Size means Object_Size. This is the other respect in
4951 -- which VADS_Size differs from Size.
4953 if Is_Scalar_Type
(Ptyp
) and then No
(Size_Clause
(Ptyp
)) then
4954 Set_Attribute_Name
(N
, Name_Object_Size
);
4956 -- In all other cases, Size and VADS_Size are the sane
4959 Set_Attribute_Name
(N
, Name_Size
);
4964 -- For class-wide types, X'Class'Size is transformed into a direct
4965 -- reference to the Size of the class type, so that the back end does
4966 -- not have to deal with the X'Class'Size reference.
4968 if Is_Entity_Name
(Pref
)
4969 and then Is_Class_Wide_Type
(Entity
(Pref
))
4971 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4974 -- For X'Size applied to an object of a class-wide type, transform
4975 -- X'Size into a call to the primitive operation _Size applied to X.
4977 elsif Is_Class_Wide_Type
(Ptyp
)
4978 or else (Id
= Attribute_Size
4979 and then Is_Tagged_Type
(Ptyp
)
4980 and then Has_Unknown_Discriminants
(Ptyp
))
4982 -- No need to do anything else compiling under restriction
4983 -- No_Dispatching_Calls. During the semantic analysis we
4984 -- already notified such violation.
4986 if Restriction_Active
(No_Dispatching_Calls
) then
4991 Make_Function_Call
(Loc
,
4992 Name
=> New_Reference_To
4993 (Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
4994 Parameter_Associations
=> New_List
(Pref
));
4996 if Typ
/= Standard_Long_Long_Integer
then
4998 -- The context is a specific integer type with which the
4999 -- original attribute was compatible. The function has a
5000 -- specific type as well, so to preserve the compatibility
5001 -- we must convert explicitly.
5003 New_Node
:= Convert_To
(Typ
, New_Node
);
5006 Rewrite
(N
, New_Node
);
5007 Analyze_And_Resolve
(N
, Typ
);
5010 -- Case of known RM_Size of a type
5012 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
5013 and then Is_Entity_Name
(Pref
)
5014 and then Is_Type
(Entity
(Pref
))
5015 and then Known_Static_RM_Size
(Entity
(Pref
))
5017 Siz
:= RM_Size
(Entity
(Pref
));
5019 -- Case of known Esize of a type
5021 elsif Id
= Attribute_Object_Size
5022 and then Is_Entity_Name
(Pref
)
5023 and then Is_Type
(Entity
(Pref
))
5024 and then Known_Static_Esize
(Entity
(Pref
))
5026 Siz
:= Esize
(Entity
(Pref
));
5028 -- Case of known size of object
5030 elsif Id
= Attribute_Size
5031 and then Is_Entity_Name
(Pref
)
5032 and then Is_Object
(Entity
(Pref
))
5033 and then Known_Esize
(Entity
(Pref
))
5034 and then Known_Static_Esize
(Entity
(Pref
))
5036 Siz
:= Esize
(Entity
(Pref
));
5038 -- For an array component, we can do Size in the front end
5039 -- if the component_size of the array is set.
5041 elsif Nkind
(Pref
) = N_Indexed_Component
then
5042 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
5044 -- For a record component, we can do Size in the front end if there
5045 -- is a component clause, or if the record is packed and the
5046 -- component's size is known at compile time.
5048 elsif Nkind
(Pref
) = N_Selected_Component
then
5050 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
5051 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
5054 if Present
(Component_Clause
(Comp
)) then
5055 Siz
:= Esize
(Comp
);
5057 elsif Is_Packed
(Rec
) then
5058 Siz
:= RM_Size
(Ptyp
);
5061 Apply_Universal_Integer_Attribute_Checks
(N
);
5066 -- All other cases are handled by the back end
5069 Apply_Universal_Integer_Attribute_Checks
(N
);
5071 -- If Size is applied to a formal parameter that is of a packed
5072 -- array subtype, then apply Size to the actual subtype.
5074 if Is_Entity_Name
(Pref
)
5075 and then Is_Formal
(Entity
(Pref
))
5076 and then Is_Array_Type
(Ptyp
)
5077 and then Is_Packed
(Ptyp
)
5080 Make_Attribute_Reference
(Loc
,
5082 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
5083 Attribute_Name
=> Name_Size
));
5084 Analyze_And_Resolve
(N
, Typ
);
5087 -- If Size applies to a dereference of an access to unconstrained
5088 -- packed array, the back end needs to see its unconstrained
5089 -- nominal type, but also a hint to the actual constrained type.
5091 if Nkind
(Pref
) = N_Explicit_Dereference
5092 and then Is_Array_Type
(Ptyp
)
5093 and then not Is_Constrained
(Ptyp
)
5094 and then Is_Packed
(Ptyp
)
5096 Set_Actual_Designated_Subtype
(Pref
,
5097 Get_Actual_Subtype
(Pref
));
5103 -- Common processing for record and array component case
5105 if Siz
/= No_Uint
and then Siz
/= 0 then
5107 CS
: constant Boolean := Comes_From_Source
(N
);
5110 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
5112 -- This integer literal is not a static expression. We do not
5113 -- call Analyze_And_Resolve here, because this would activate
5114 -- the circuit for deciding that a static value was out of
5115 -- range, and we don't want that.
5117 -- So just manually set the type, mark the expression as non-
5118 -- static, and then ensure that the result is checked properly
5119 -- if the attribute comes from source (if it was internally
5120 -- generated, we never need a constraint check).
5123 Set_Is_Static_Expression
(N
, False);
5126 Apply_Constraint_Check
(N
, Typ
);
5136 when Attribute_Storage_Pool
=>
5138 Make_Type_Conversion
(Loc
,
5139 Subtype_Mark
=> New_Reference_To
(Etype
(N
), Loc
),
5140 Expression
=> New_Reference_To
(Entity
(N
), Loc
)));
5141 Analyze_And_Resolve
(N
, Typ
);
5147 when Attribute_Storage_Size
=> Storage_Size
: declare
5148 Alloc_Op
: Entity_Id
:= Empty
;
5152 -- Access type case, always go to the root type
5154 -- The case of access types results in a value of zero for the case
5155 -- where no storage size attribute clause has been given. If a
5156 -- storage size has been given, then the attribute is converted
5157 -- to a reference to the variable used to hold this value.
5159 if Is_Access_Type
(Ptyp
) then
5160 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
5162 Make_Attribute_Reference
(Loc
,
5163 Prefix
=> New_Reference_To
(Typ
, Loc
),
5164 Attribute_Name
=> Name_Max
,
5165 Expressions
=> New_List
(
5166 Make_Integer_Literal
(Loc
, 0),
5169 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
5171 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
5173 -- If the access type is associated with a simple storage pool
5174 -- object, then attempt to locate the optional Storage_Size
5175 -- function of the simple storage pool type. If not found,
5176 -- then the result will default to zero.
5178 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
5179 Name_Simple_Storage_Pool_Type
))
5182 Pool_Type
: constant Entity_Id
:=
5183 Base_Type
(Etype
(Entity
(N
)));
5186 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
5187 while Present
(Alloc_Op
) loop
5188 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
5189 and then Present
(First_Formal
(Alloc_Op
))
5190 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
5195 Alloc_Op
:= Homonym
(Alloc_Op
);
5199 -- In the normal Storage_Pool case, retrieve the primitive
5200 -- function associated with the pool type.
5205 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
5206 Attribute_Name
(N
));
5209 -- If Storage_Size wasn't found (can only occur in the simple
5210 -- storage pool case), then simply use zero for the result.
5212 if not Present
(Alloc_Op
) then
5213 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5215 -- Otherwise, rewrite the allocator as a call to pool type's
5216 -- Storage_Size function.
5221 Make_Function_Call
(Loc
,
5223 New_Reference_To
(Alloc_Op
, Loc
),
5225 Parameter_Associations
=> New_List
(
5227 (Associated_Storage_Pool
5228 (Root_Type
(Ptyp
)), Loc
)))));
5232 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
5235 Analyze_And_Resolve
(N
, Typ
);
5237 -- For tasks, we retrieve the size directly from the TCB. The
5238 -- size may depend on a discriminant of the type, and therefore
5239 -- can be a per-object expression, so type-level information is
5240 -- not sufficient in general. There are four cases to consider:
5242 -- a) If the attribute appears within a task body, the designated
5243 -- TCB is obtained by a call to Self.
5245 -- b) If the prefix of the attribute is the name of a task object,
5246 -- the designated TCB is the one stored in the corresponding record.
5248 -- c) If the prefix is a task type, the size is obtained from the
5249 -- size variable created for each task type
5251 -- d) If no storage_size was specified for the type , there is no
5252 -- size variable, and the value is a system-specific default.
5255 if In_Open_Scopes
(Ptyp
) then
5257 -- Storage_Size (Self)
5261 Make_Function_Call
(Loc
,
5263 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5264 Parameter_Associations
=>
5266 Make_Function_Call
(Loc
,
5268 New_Reference_To
(RTE
(RE_Self
), Loc
))))));
5270 elsif not Is_Entity_Name
(Pref
)
5271 or else not Is_Type
(Entity
(Pref
))
5273 -- Storage_Size (Rec (Obj).Size)
5277 Make_Function_Call
(Loc
,
5279 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
5280 Parameter_Associations
=>
5282 Make_Selected_Component
(Loc
,
5284 Unchecked_Convert_To
(
5285 Corresponding_Record_Type
(Ptyp
),
5286 New_Copy_Tree
(Pref
)),
5288 Make_Identifier
(Loc
, Name_uTask_Id
))))));
5290 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
5292 -- Static storage size pragma given for type: retrieve value
5293 -- from its allocated storage variable.
5297 Make_Function_Call
(Loc
,
5298 Name
=> New_Occurrence_Of
(
5299 RTE
(RE_Adjust_Storage_Size
), Loc
),
5300 Parameter_Associations
=>
5303 Storage_Size_Variable
(Ptyp
), Loc
)))));
5305 -- Get system default
5309 Make_Function_Call
(Loc
,
5312 RTE
(RE_Default_Stack_Size
), Loc
))));
5315 Analyze_And_Resolve
(N
, Typ
);
5323 when Attribute_Stream_Size
=>
5325 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
5326 Analyze_And_Resolve
(N
, Typ
);
5332 -- 1. Deal with enumeration types with holes
5333 -- 2. For floating-point, generate call to attribute function
5334 -- 3. For other cases, deal with constraint checking
5336 when Attribute_Succ
=> Succ
: declare
5337 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5341 -- For enumeration types with non-standard representations, we
5342 -- expand typ'Succ (x) into
5344 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
5346 -- If the representation is contiguous, we compute instead
5347 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
5349 if Is_Enumeration_Type
(Ptyp
)
5350 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5352 if Has_Contiguous_Rep
(Etyp
) then
5354 Unchecked_Convert_To
(Ptyp
,
5357 Make_Integer_Literal
(Loc
,
5358 Enumeration_Rep
(First_Literal
(Ptyp
))),
5360 Make_Function_Call
(Loc
,
5363 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5365 Parameter_Associations
=>
5367 Unchecked_Convert_To
(Ptyp
,
5370 Unchecked_Convert_To
(Standard_Integer
,
5371 Relocate_Node
(First
(Exprs
))),
5373 Make_Integer_Literal
(Loc
, 1))),
5374 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
5376 -- Add Boolean parameter True, to request program errror if
5377 -- we have a bad representation on our hands. Add False if
5378 -- checks are suppressed.
5380 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5382 Make_Indexed_Component
(Loc
,
5385 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5386 Expressions
=> New_List
(
5389 Make_Function_Call
(Loc
,
5392 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5393 Parameter_Associations
=> Exprs
),
5394 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5397 Analyze_And_Resolve
(N
, Typ
);
5399 -- For floating-point, we transform 'Succ into a call to the Succ
5400 -- floating-point attribute function in Fat_xxx (xxx is root type)
5402 elsif Is_Floating_Point_Type
(Ptyp
) then
5403 Expand_Fpt_Attribute_R
(N
);
5404 Analyze_And_Resolve
(N
, Typ
);
5406 -- For modular types, nothing to do (no overflow, since wraps)
5408 elsif Is_Modular_Integer_Type
(Ptyp
) then
5411 -- For other types, if argument is marked as needing a range check or
5412 -- overflow checking is enabled, we must generate a check.
5414 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5415 or else Do_Range_Check
(First
(Exprs
))
5417 Set_Do_Range_Check
(First
(Exprs
), False);
5418 Expand_Pred_Succ
(N
);
5426 -- Transforms X'Tag into a direct reference to the tag of X
5428 when Attribute_Tag
=> Tag
: declare
5430 Prefix_Is_Type
: Boolean;
5433 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
5434 Ttyp
:= Entity
(Pref
);
5435 Prefix_Is_Type
:= True;
5438 Prefix_Is_Type
:= False;
5441 if Is_Class_Wide_Type
(Ttyp
) then
5442 Ttyp
:= Root_Type
(Ttyp
);
5445 Ttyp
:= Underlying_Type
(Ttyp
);
5447 -- Ada 2005: The type may be a synchronized tagged type, in which
5448 -- case the tag information is stored in the corresponding record.
5450 if Is_Concurrent_Type
(Ttyp
) then
5451 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
5454 if Prefix_Is_Type
then
5456 -- For VMs we leave the type attribute unexpanded because
5457 -- there's not a dispatching table to reference.
5459 if Tagged_Type_Expansion
then
5461 Unchecked_Convert_To
(RTE
(RE_Tag
),
5463 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
5464 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5467 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
5468 -- references the primary tag of the actual object. If 'Tag is
5469 -- applied to class-wide interface objects we generate code that
5470 -- displaces "this" to reference the base of the object.
5472 elsif Comes_From_Source
(N
)
5473 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
5474 and then Is_Interface
(Etype
(Prefix
(N
)))
5477 -- (To_Tag_Ptr (Prefix'Address)).all
5479 -- Note that Prefix'Address is recursively expanded into a call
5480 -- to Base_Address (Obj.Tag)
5482 -- Not needed for VM targets, since all handled by the VM
5484 if Tagged_Type_Expansion
then
5486 Make_Explicit_Dereference
(Loc
,
5487 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
5488 Make_Attribute_Reference
(Loc
,
5489 Prefix
=> Relocate_Node
(Pref
),
5490 Attribute_Name
=> Name_Address
))));
5491 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5496 Make_Selected_Component
(Loc
,
5497 Prefix
=> Relocate_Node
(Pref
),
5499 New_Reference_To
(First_Tag_Component
(Ttyp
), Loc
)));
5500 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
5508 -- Transforms 'Terminated attribute into a call to Terminated function
5510 when Attribute_Terminated
=> Terminated
:
5512 -- The prefix of Terminated is of a task interface class-wide type.
5514 -- terminated (Task_Id (Pref._disp_get_task_id));
5516 if Ada_Version
>= Ada_2005
5517 and then Ekind
(Ptyp
) = E_Class_Wide_Type
5518 and then Is_Interface
(Ptyp
)
5519 and then Is_Task_Interface
(Ptyp
)
5522 Make_Function_Call
(Loc
,
5524 New_Reference_To
(RTE
(RE_Terminated
), Loc
),
5525 Parameter_Associations
=> New_List
(
5526 Make_Unchecked_Type_Conversion
(Loc
,
5528 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
5530 Make_Selected_Component
(Loc
,
5532 New_Copy_Tree
(Pref
),
5534 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
5536 elsif Restricted_Profile
then
5538 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
5542 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
5545 Analyze_And_Resolve
(N
, Standard_Boolean
);
5552 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
5553 -- unchecked conversion from (integral) type of X to type address.
5555 when Attribute_To_Address | Attribute_Ref
=>
5557 Unchecked_Convert_To
(RTE
(RE_Address
),
5558 Relocate_Node
(First
(Exprs
))));
5559 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
5565 when Attribute_To_Any
=> To_Any
: declare
5566 P_Type
: constant Entity_Id
:= Etype
(Pref
);
5567 Decls
: constant List_Id
:= New_List
;
5573 Relocate_Node
(First
(Exprs
))), Decls
));
5574 Insert_Actions
(N
, Decls
);
5575 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
5582 -- Transforms 'Truncation into a call to the floating-point attribute
5583 -- function Truncation in Fat_xxx (where xxx is the root type).
5584 -- Expansion is avoided for cases the back end can handle directly.
5586 when Attribute_Truncation
=>
5587 if not Is_Inline_Floating_Point_Attribute
(N
) then
5588 Expand_Fpt_Attribute_R
(N
);
5595 when Attribute_TypeCode
=> TypeCode
: declare
5596 P_Type
: constant Entity_Id
:= Etype
(Pref
);
5597 Decls
: constant List_Id
:= New_List
;
5599 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
5600 Insert_Actions
(N
, Decls
);
5601 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
5604 -----------------------
5605 -- Unbiased_Rounding --
5606 -----------------------
5608 -- Transforms 'Unbiased_Rounding into a call to the floating-point
5609 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
5610 -- root type). Expansion is avoided for cases the back end can handle
5613 when Attribute_Unbiased_Rounding
=>
5614 if not Is_Inline_Floating_Point_Attribute
(N
) then
5615 Expand_Fpt_Attribute_R
(N
);
5622 when Attribute_UET_Address
=> UET_Address
: declare
5623 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
5627 Make_Object_Declaration
(Loc
,
5628 Defining_Identifier
=> Ent
,
5629 Aliased_Present
=> True,
5630 Object_Definition
=>
5631 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
5633 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
5634 -- in normal external form.
5636 Get_External_Unit_Name_String
(Get_Unit_Name
(Pref
));
5637 Name_Buffer
(1 + 7 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
5638 Name_Len
:= Name_Len
+ 7;
5639 Name_Buffer
(1 .. 7) := "__gnat_";
5640 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 5) := "__SDP";
5641 Name_Len
:= Name_Len
+ 5;
5643 Set_Is_Imported
(Ent
);
5644 Set_Interface_Name
(Ent
,
5645 Make_String_Literal
(Loc
,
5646 Strval
=> String_From_Name_Buffer
));
5648 -- Set entity as internal to ensure proper Sprint output of its
5649 -- implicit importation.
5651 Set_Is_Internal
(Ent
);
5654 Make_Attribute_Reference
(Loc
,
5655 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
5656 Attribute_Name
=> Name_Address
));
5658 Analyze_And_Resolve
(N
, Typ
);
5665 when Attribute_Update
=>
5666 Expand_Update_Attribute
(N
);
5672 -- The processing for VADS_Size is shared with Size
5678 -- For enumeration types with a standard representation, and for all
5679 -- other types, Val is handled by the back end. For enumeration types
5680 -- with a non-standard representation we use the _Pos_To_Rep array that
5681 -- was created when the type was frozen.
5683 when Attribute_Val
=> Val
: declare
5684 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
5687 if Is_Enumeration_Type
(Etyp
)
5688 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5690 if Has_Contiguous_Rep
(Etyp
) then
5692 Rep_Node
: constant Node_Id
:=
5693 Unchecked_Convert_To
(Etyp
,
5696 Make_Integer_Literal
(Loc
,
5697 Enumeration_Rep
(First_Literal
(Etyp
))),
5699 (Convert_To
(Standard_Integer
,
5700 Relocate_Node
(First
(Exprs
))))));
5704 Unchecked_Convert_To
(Etyp
,
5707 Make_Integer_Literal
(Loc
,
5708 Enumeration_Rep
(First_Literal
(Etyp
))),
5710 Make_Function_Call
(Loc
,
5713 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5714 Parameter_Associations
=> New_List
(
5716 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
5721 Make_Indexed_Component
(Loc
,
5722 Prefix
=> New_Reference_To
(Enum_Pos_To_Rep
(Etyp
), Loc
),
5723 Expressions
=> New_List
(
5724 Convert_To
(Standard_Integer
,
5725 Relocate_Node
(First
(Exprs
))))));
5728 Analyze_And_Resolve
(N
, Typ
);
5730 -- If the argument is marked as requiring a range check then generate
5733 elsif Do_Range_Check
(First
(Exprs
)) then
5734 Set_Do_Range_Check
(First
(Exprs
), False);
5735 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
5743 -- The code for valid is dependent on the particular types involved.
5744 -- See separate sections below for the generated code in each case.
5746 when Attribute_Valid
=> Valid
: declare
5747 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
5750 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
5751 -- Save the validity checking mode. We always turn off validity
5752 -- checking during process of 'Valid since this is one place
5753 -- where we do not want the implicit validity checks to intefere
5754 -- with the explicit validity check that the programmer is doing.
5756 function Make_Range_Test
return Node_Id
;
5757 -- Build the code for a range test of the form
5758 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
5760 ---------------------
5761 -- Make_Range_Test --
5762 ---------------------
5764 function Make_Range_Test
return Node_Id
is
5765 Temp
: constant Node_Id
:= Duplicate_Subexpr
(Pref
);
5768 -- The value whose validity is being checked has been captured in
5769 -- an object declaration. We certainly don't want this object to
5770 -- appear valid because the declaration initializes it!
5772 if Is_Entity_Name
(Temp
) then
5773 Set_Is_Known_Valid
(Entity
(Temp
), False);
5779 Unchecked_Convert_To
(Btyp
, Temp
),
5783 Unchecked_Convert_To
(Btyp
,
5784 Make_Attribute_Reference
(Loc
,
5785 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5786 Attribute_Name
=> Name_First
)),
5788 Unchecked_Convert_To
(Btyp
,
5789 Make_Attribute_Reference
(Loc
,
5790 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5791 Attribute_Name
=> Name_Last
))));
5792 end Make_Range_Test
;
5794 -- Start of processing for Attribute_Valid
5797 -- Do not expand sourced code 'Valid reference in CodePeer mode,
5798 -- will be handled by the back-end directly.
5800 if CodePeer_Mode
and then Comes_From_Source
(N
) then
5804 -- Turn off validity checks. We do not want any implicit validity
5805 -- checks to intefere with the explicit check from the attribute
5807 Validity_Checks_On
:= False;
5809 -- Retrieve the base type. Handle the case where the base type is a
5810 -- private enumeration type.
5812 if Is_Private_Type
(Btyp
) and then Present
(Full_View
(Btyp
)) then
5813 Btyp
:= Full_View
(Btyp
);
5816 -- Floating-point case. This case is handled by the Valid attribute
5817 -- code in the floating-point attribute run-time library.
5819 if Is_Floating_Point_Type
(Ptyp
) then
5825 case Float_Rep
(Btyp
) is
5827 -- For vax fpt types, call appropriate routine in special
5828 -- vax floating point unit. No need to worry about loads in
5829 -- this case, since these types have no signalling NaN's.
5831 when VAX_Native
=> Expand_Vax_Valid
(N
);
5833 -- The AAMP back end handles Valid for floating-point types
5836 Analyze_And_Resolve
(Pref
, Ptyp
);
5837 Set_Etype
(N
, Standard_Boolean
);
5841 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
5843 -- If the floating-point object might be unaligned, we
5844 -- need to call the special routine Unaligned_Valid,
5845 -- which makes the needed copy, being careful not to
5846 -- load the value into any floating-point register.
5847 -- The argument in this case is obj'Address (see
5848 -- Unaligned_Valid routine in Fat_Gen).
5850 if Is_Possibly_Unaligned_Object
(Pref
) then
5851 Expand_Fpt_Attribute
5852 (N
, Pkg
, Name_Unaligned_Valid
,
5854 Make_Attribute_Reference
(Loc
,
5855 Prefix
=> Relocate_Node
(Pref
),
5856 Attribute_Name
=> Name_Address
)));
5858 -- In the normal case where we are sure the object is
5859 -- aligned, we generate a call to Valid, and the argument
5860 -- in this case is obj'Unrestricted_Access (after
5861 -- converting obj to the right floating-point type).
5864 Expand_Fpt_Attribute
5865 (N
, Pkg
, Name_Valid
,
5867 Make_Attribute_Reference
(Loc
,
5868 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
5869 Attribute_Name
=> Name_Unrestricted_Access
)));
5873 -- One more task, we still need a range check. Required
5874 -- only if we have a constraint, since the Valid routine
5875 -- catches infinities properly (infinities are never valid).
5877 -- The way we do the range check is simply to create the
5878 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
5880 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
5883 Left_Opnd
=> Relocate_Node
(N
),
5886 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
5887 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
5891 -- Enumeration type with holes
5893 -- For enumeration types with holes, the Pos value constructed by
5894 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
5895 -- second argument of False returns minus one for an invalid value,
5896 -- and the non-negative pos value for a valid value, so the
5897 -- expansion of X'Valid is simply:
5899 -- type(X)'Pos (X) >= 0
5901 -- We can't quite generate it that way because of the requirement
5902 -- for the non-standard second argument of False in the resulting
5903 -- rep_to_pos call, so we have to explicitly create:
5905 -- _rep_to_pos (X, False) >= 0
5907 -- If we have an enumeration subtype, we also check that the
5908 -- value is in range:
5910 -- _rep_to_pos (X, False) >= 0
5912 -- (X >= type(X)'First and then type(X)'Last <= X)
5914 elsif Is_Enumeration_Type
(Ptyp
)
5915 and then Present
(Enum_Pos_To_Rep
(Btyp
))
5920 Make_Function_Call
(Loc
,
5922 New_Reference_To
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
5923 Parameter_Associations
=> New_List
(
5925 New_Occurrence_Of
(Standard_False
, Loc
))),
5926 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
5930 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
5932 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
5934 -- The call to Make_Range_Test will create declarations
5935 -- that need a proper insertion point, but Pref is now
5936 -- attached to a node with no ancestor. Attach to tree
5937 -- even if it is to be rewritten below.
5939 Set_Parent
(Tst
, Parent
(N
));
5943 Left_Opnd
=> Make_Range_Test
,
5949 -- Fortran convention booleans
5951 -- For the very special case of Fortran convention booleans, the
5952 -- value is always valid, since it is an integer with the semantics
5953 -- that non-zero is true, and any value is permissible.
5955 elsif Is_Boolean_Type
(Ptyp
)
5956 and then Convention
(Ptyp
) = Convention_Fortran
5958 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
5960 -- For biased representations, we will be doing an unchecked
5961 -- conversion without unbiasing the result. That means that the range
5962 -- test has to take this into account, and the proper form of the
5965 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
5967 elsif Has_Biased_Representation
(Ptyp
) then
5968 Btyp
:= RTE
(RE_Unsigned_32
);
5972 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
5974 Unchecked_Convert_To
(Btyp
,
5975 Make_Attribute_Reference
(Loc
,
5976 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
5977 Attribute_Name
=> Name_Range_Length
))));
5979 -- For all other scalar types, what we want logically is a
5982 -- X in type(X)'First .. type(X)'Last
5984 -- But that's precisely what won't work because of possible
5985 -- unwanted optimization (and indeed the basic motivation for
5986 -- the Valid attribute is exactly that this test does not work!)
5987 -- What will work is:
5989 -- Btyp!(X) >= Btyp!(type(X)'First)
5991 -- Btyp!(X) <= Btyp!(type(X)'Last)
5993 -- where Btyp is an integer type large enough to cover the full
5994 -- range of possible stored values (i.e. it is chosen on the basis
5995 -- of the size of the type, not the range of the values). We write
5996 -- this as two tests, rather than a range check, so that static
5997 -- evaluation will easily remove either or both of the checks if
5998 -- they can be -statically determined to be true (this happens
5999 -- when the type of X is static and the range extends to the full
6000 -- range of stored values).
6002 -- Unsigned types. Note: it is safe to consider only whether the
6003 -- subtype is unsigned, since we will in that case be doing all
6004 -- unsigned comparisons based on the subtype range. Since we use the
6005 -- actual subtype object size, this is appropriate.
6007 -- For example, if we have
6009 -- subtype x is integer range 1 .. 200;
6010 -- for x'Object_Size use 8;
6012 -- Now the base type is signed, but objects of this type are bits
6013 -- unsigned, and doing an unsigned test of the range 1 to 200 is
6014 -- correct, even though a value greater than 127 looks signed to a
6015 -- signed comparison.
6017 elsif Is_Unsigned_Type
(Ptyp
) then
6018 if Esize
(Ptyp
) <= 32 then
6019 Btyp
:= RTE
(RE_Unsigned_32
);
6021 Btyp
:= RTE
(RE_Unsigned_64
);
6024 Rewrite
(N
, Make_Range_Test
);
6029 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
6030 Btyp
:= Standard_Integer
;
6032 Btyp
:= Universal_Integer
;
6035 Rewrite
(N
, Make_Range_Test
);
6038 -- If a predicate is present, then we do the predicate test, even if
6039 -- within the predicate function (infinite recursion is warned about
6040 -- in Sem_Attr in that case).
6043 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
6046 if Present
(Pred_Func
) then
6049 Left_Opnd
=> Relocate_Node
(N
),
6050 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
6054 Analyze_And_Resolve
(N
, Standard_Boolean
);
6055 Validity_Checks_On
:= Save_Validity_Checks_On
;
6062 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
6066 if Present
(Underlying_Type
(Ptyp
)) then
6067 Ftyp
:= Underlying_Type
(Ptyp
);
6072 -- For scalar types, Valid_Scalars is the same as Valid
6074 if Is_Scalar_Type
(Ftyp
) then
6076 Make_Attribute_Reference
(Loc
,
6077 Attribute_Name
=> Name_Valid
,
6079 Analyze_And_Resolve
(N
, Standard_Boolean
);
6081 -- For array types, we construct a function that determines if there
6082 -- are any non-valid scalar subcomponents, and call the function.
6083 -- We only do this for arrays whose component type needs checking
6085 elsif Is_Array_Type
(Ftyp
)
6086 and then not No_Scalar_Parts
(Component_Type
(Ftyp
))
6089 Make_Function_Call
(Loc
,
6091 New_Occurrence_Of
(Build_Array_VS_Func
(Ftyp
, N
), Loc
),
6092 Parameter_Associations
=> New_List
(Pref
)));
6094 Analyze_And_Resolve
(N
, Standard_Boolean
);
6096 -- For record types, we build a big if expression, applying Valid or
6097 -- Valid_Scalars as appropriate to all relevant components.
6099 elsif (Is_Record_Type
(Ptyp
) or else Has_Discriminants
(Ptyp
))
6100 and then not No_Scalar_Parts
(Ptyp
)
6108 X
:= New_Occurrence_Of
(Standard_True
, Loc
);
6109 C
:= First_Component_Or_Discriminant
(Ptyp
);
6110 while Present
(C
) loop
6111 if No_Scalar_Parts
(Etype
(C
)) then
6113 elsif Is_Scalar_Type
(Etype
(C
)) then
6116 A
:= Name_Valid_Scalars
;
6123 Make_Attribute_Reference
(Loc
,
6124 Attribute_Name
=> A
,
6126 Make_Selected_Component
(Loc
,
6128 Duplicate_Subexpr
(Pref
, Name_Req
=> True),
6130 New_Occurrence_Of
(C
, Loc
))));
6132 Next_Component_Or_Discriminant
(C
);
6136 Analyze_And_Resolve
(N
, Standard_Boolean
);
6139 -- For all other types, result is True (but not static)
6142 Rewrite
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
6143 Analyze_And_Resolve
(N
, Standard_Boolean
);
6144 Set_Is_Static_Expression
(N
, False);
6152 -- Value attribute is handled in separate unit Exp_Imgv
6154 when Attribute_Value
=>
6155 Exp_Imgv
.Expand_Value_Attribute
(N
);
6161 -- The processing for Value_Size shares the processing for Size
6167 -- The processing for Version shares the processing for Body_Version
6173 -- Wide_Image attribute is handled in separate unit Exp_Imgv
6175 when Attribute_Wide_Image
=>
6176 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
6178 ---------------------
6179 -- Wide_Wide_Image --
6180 ---------------------
6182 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
6184 when Attribute_Wide_Wide_Image
=>
6185 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
6191 -- We expand typ'Wide_Value (X) into
6194 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
6196 -- Wide_String_To_String is a runtime function that converts its wide
6197 -- string argument to String, converting any non-translatable characters
6198 -- into appropriate escape sequences. This preserves the required
6199 -- semantics of Wide_Value in all cases, and results in a very simple
6200 -- implementation approach.
6202 -- Note: for this approach to be fully standard compliant for the cases
6203 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
6204 -- method must cover the entire character range (e.g. UTF-8). But that
6205 -- is a reasonable requirement when dealing with encoded character
6206 -- sequences. Presumably if one of the restrictive encoding mechanisms
6207 -- is in use such as Shift-JIS, then characters that cannot be
6208 -- represented using this encoding will not appear in any case.
6210 when Attribute_Wide_Value
=> Wide_Value
:
6213 Make_Attribute_Reference
(Loc
,
6215 Attribute_Name
=> Name_Value
,
6217 Expressions
=> New_List
(
6218 Make_Function_Call
(Loc
,
6220 New_Reference_To
(RTE
(RE_Wide_String_To_String
), Loc
),
6222 Parameter_Associations
=> New_List
(
6223 Relocate_Node
(First
(Exprs
)),
6224 Make_Integer_Literal
(Loc
,
6225 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6227 Analyze_And_Resolve
(N
, Typ
);
6230 ---------------------
6231 -- Wide_Wide_Value --
6232 ---------------------
6234 -- We expand typ'Wide_Value_Value (X) into
6237 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
6239 -- Wide_Wide_String_To_String is a runtime function that converts its
6240 -- wide string argument to String, converting any non-translatable
6241 -- characters into appropriate escape sequences. This preserves the
6242 -- required semantics of Wide_Wide_Value in all cases, and results in a
6243 -- very simple implementation approach.
6245 -- It's not quite right where typ = Wide_Wide_Character, because the
6246 -- encoding method may not cover the whole character type ???
6248 when Attribute_Wide_Wide_Value
=> Wide_Wide_Value
:
6251 Make_Attribute_Reference
(Loc
,
6253 Attribute_Name
=> Name_Value
,
6255 Expressions
=> New_List
(
6256 Make_Function_Call
(Loc
,
6258 New_Reference_To
(RTE
(RE_Wide_Wide_String_To_String
), Loc
),
6260 Parameter_Associations
=> New_List
(
6261 Relocate_Node
(First
(Exprs
)),
6262 Make_Integer_Literal
(Loc
,
6263 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
6265 Analyze_And_Resolve
(N
, Typ
);
6266 end Wide_Wide_Value
;
6268 ---------------------
6269 -- Wide_Wide_Width --
6270 ---------------------
6272 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
6274 when Attribute_Wide_Wide_Width
=>
6275 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
6281 -- Wide_Width attribute is handled in separate unit Exp_Imgv
6283 when Attribute_Wide_Width
=>
6284 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
6290 -- Width attribute is handled in separate unit Exp_Imgv
6292 when Attribute_Width
=>
6293 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
6299 when Attribute_Write
=> Write
: declare
6300 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6301 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6309 -- If no underlying type, we have an error that will be diagnosed
6310 -- elsewhere, so here we just completely ignore the expansion.
6316 -- The simple case, if there is a TSS for Write, just call it
6318 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
6320 if Present
(Pname
) then
6324 -- If there is a Stream_Convert pragma, use it, we rewrite
6326 -- sourcetyp'Output (stream, Item)
6330 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
6332 -- where strmwrite is the given Write function that converts an
6333 -- argument of type sourcetyp or a type acctyp, from which it is
6334 -- derived to type strmtyp. The conversion to acttyp is required
6335 -- for the derived case.
6337 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6339 if Present
(Prag
) then
6341 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
6342 Wfunc
:= Entity
(Expression
(Arg3
));
6345 Make_Attribute_Reference
(Loc
,
6346 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
6347 Attribute_Name
=> Name_Output
,
6348 Expressions
=> New_List
(
6349 Relocate_Node
(First
(Exprs
)),
6350 Make_Function_Call
(Loc
,
6351 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
6352 Parameter_Associations
=> New_List
(
6353 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
6354 Relocate_Node
(Next
(First
(Exprs
)))))))));
6359 -- For elementary types, we call the W_xxx routine directly
6361 elsif Is_Elementary_Type
(U_Type
) then
6362 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
6368 elsif Is_Array_Type
(U_Type
) then
6369 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
6370 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
6372 -- Tagged type case, use the primitive Write function. Note that
6373 -- this will dispatch in the class-wide case which is what we want
6375 elsif Is_Tagged_Type
(U_Type
) then
6376 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
6378 -- All other record type cases, including protected records.
6379 -- The latter only arise for expander generated code for
6380 -- handling shared passive partition access.
6384 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
6386 -- Ada 2005 (AI-216): Program_Error is raised when executing
6387 -- the default implementation of the Write attribute of an
6388 -- Unchecked_Union type. However, if the 'Write reference is
6389 -- within the generated Output stream procedure, Write outputs
6390 -- the components, and the default values of the discriminant
6391 -- are streamed by the Output procedure itself.
6393 if Is_Unchecked_Union
(Base_Type
(U_Type
))
6394 and not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
6397 Make_Raise_Program_Error
(Loc
,
6398 Reason
=> PE_Unchecked_Union_Restriction
));
6401 if Has_Discriminants
(U_Type
)
6403 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
6405 Build_Mutable_Record_Write_Procedure
6406 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6408 Build_Record_Write_Procedure
6409 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
6412 Insert_Action
(N
, Decl
);
6416 -- If we fall through, Pname is the procedure to be called
6418 Rewrite_Stream_Proc_Call
(Pname
);
6421 -- Component_Size is handled by the back end, unless the component size
6422 -- is known at compile time, which is always true in the packed array
6423 -- case. It is important that the packed array case is handled in the
6424 -- front end (see Eval_Attribute) since the back end would otherwise get
6425 -- confused by the equivalent packed array type.
6427 when Attribute_Component_Size
=>
6430 -- The following attributes are handled by the back end (except that
6431 -- static cases have already been evaluated during semantic processing,
6432 -- but in any case the back end should not count on this). The one bit
6433 -- of special processing required is that these attributes typically
6434 -- generate conditionals in the code, so we need to check the relevant
6437 when Attribute_Max |
6439 Check_Restriction
(No_Implicit_Conditionals
, N
);
6441 -- The following attributes are handled by the back end (except that
6442 -- static cases have already been evaluated during semantic processing,
6443 -- but in any case the back end should not count on this).
6445 -- The back end also handles the non-class-wide cases of Size
6447 when Attribute_Bit_Order |
6448 Attribute_Code_Address |
6449 Attribute_Definite |
6450 Attribute_Null_Parameter |
6451 Attribute_Passed_By_Reference |
6452 Attribute_Pool_Address |
6453 Attribute_Scalar_Storage_Order
=>
6456 -- The following attributes are also handled by the back end, but return
6457 -- a universal integer result, so may need a conversion for checking
6458 -- that the result is in range.
6460 when Attribute_Aft |
6461 Attribute_Max_Alignment_For_Allocation
=>
6462 Apply_Universal_Integer_Attribute_Checks
(N
);
6464 -- The following attributes should not appear at this stage, since they
6465 -- have already been handled by the analyzer (and properly rewritten
6466 -- with corresponding values or entities to represent the right values)
6468 when Attribute_Abort_Signal |
6469 Attribute_Address_Size |
6470 Attribute_Atomic_Always_Lock_Free |
6473 Attribute_Compiler_Version |
6474 Attribute_Default_Bit_Order |
6481 Attribute_Fast_Math |
6482 Attribute_First_Valid |
6483 Attribute_Has_Access_Values |
6484 Attribute_Has_Discriminants |
6485 Attribute_Has_Tagged_Values |
6487 Attribute_Last_Valid |
6488 Attribute_Lock_Free |
6489 Attribute_Machine_Emax |
6490 Attribute_Machine_Emin |
6491 Attribute_Machine_Mantissa |
6492 Attribute_Machine_Overflows |
6493 Attribute_Machine_Radix |
6494 Attribute_Machine_Rounds |
6495 Attribute_Maximum_Alignment |
6496 Attribute_Model_Emin |
6497 Attribute_Model_Epsilon |
6498 Attribute_Model_Mantissa |
6499 Attribute_Model_Small |
6501 Attribute_Partition_ID |
6503 Attribute_Restriction_Set |
6504 Attribute_Safe_Emax |
6505 Attribute_Safe_First |
6506 Attribute_Safe_Large |
6507 Attribute_Safe_Last |
6508 Attribute_Safe_Small |
6510 Attribute_Signed_Zeros |
6512 Attribute_Storage_Unit |
6513 Attribute_Stub_Type |
6514 Attribute_System_Allocator_Alignment |
6515 Attribute_Target_Name |
6516 Attribute_Type_Class |
6517 Attribute_Type_Key |
6518 Attribute_Unconstrained_Array |
6519 Attribute_Universal_Literal_String |
6520 Attribute_Wchar_T_Size |
6521 Attribute_Word_Size
=>
6522 raise Program_Error
;
6524 -- The Asm_Input and Asm_Output attributes are not expanded at this
6525 -- stage, but will be eliminated in the expansion of the Asm call, see
6526 -- Exp_Intr for details. So the back end will never see these either.
6528 when Attribute_Asm_Input |
6529 Attribute_Asm_Output
=>
6533 -- Note: as mentioned earlier, individual sections of the above case
6534 -- statement assume there is no code after the case statement, and are
6535 -- legitimately allowed to execute return statements if they have nothing
6536 -- more to do, so DO NOT add code at this point.
6539 when RE_Not_Available
=>
6541 end Expand_N_Attribute_Reference
;
6543 ----------------------
6544 -- Expand_Pred_Succ --
6545 ----------------------
6547 -- For typ'Pred (exp), we generate the check
6549 -- [constraint_error when exp = typ'Base'First]
6551 -- Similarly, for typ'Succ (exp), we generate the check
6553 -- [constraint_error when exp = typ'Base'Last]
6555 -- These checks are not generated for modular types, since the proper
6556 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
6557 -- We also suppress these checks if we are the right side of an assignment
6558 -- statement or the expression of an object declaration, where the flag
6559 -- Suppress_Assignment_Checks is set for the assignment/declaration.
6561 procedure Expand_Pred_Succ
(N
: Node_Id
) is
6562 Loc
: constant Source_Ptr
:= Sloc
(N
);
6563 P
: constant Node_Id
:= Parent
(N
);
6567 if Attribute_Name
(N
) = Name_Pred
then
6573 if not Nkind_In
(P
, N_Assignment_Statement
, N_Object_Declaration
)
6574 or else not Suppress_Assignment_Checks
(P
)
6577 Make_Raise_Constraint_Error
(Loc
,
6581 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
6583 Make_Attribute_Reference
(Loc
,
6585 New_Reference_To
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
6586 Attribute_Name
=> Cnam
)),
6587 Reason
=> CE_Overflow_Check_Failed
));
6589 end Expand_Pred_Succ
;
6591 -----------------------------
6592 -- Expand_Update_Attribute --
6593 -----------------------------
6595 procedure Expand_Update_Attribute
(N
: Node_Id
) is
6596 procedure Process_Component_Or_Element_Update
6601 -- Generate the statements necessary to update a single component or an
6602 -- element of the prefix. The code is inserted before the attribute N.
6603 -- Temp denotes the entity of the anonymous object created to reflect
6604 -- the changes in values. Comp is the component/index expression to be
6605 -- updated. Expr is an expression yielding the new value of Comp. Typ
6606 -- is the type of the prefix of attribute Update.
6608 procedure Process_Range_Update
6612 -- Generate the statements necessary to update a slice of the prefix.
6613 -- The code is inserted before the attribute N. Temp denotes the entity
6614 -- of the anonymous object created to reflect the changes in values.
6615 -- Comp is range of the slice to be updated. Expr is an expression
6616 -- yielding the new value of Comp.
6618 -----------------------------------------
6619 -- Process_Component_Or_Element_Update --
6620 -----------------------------------------
6622 procedure Process_Component_Or_Element_Update
6628 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
6633 -- An array element may be modified by the following relations
6634 -- depending on the number of dimensions:
6636 -- 1 => Expr -- one dimensional update
6637 -- (1, ..., N) => Expr -- multi dimensional update
6639 -- The above forms are converted in assignment statements where the
6640 -- left hand side is an indexed component:
6642 -- Temp (1) := Expr; -- one dimensional update
6643 -- Temp (1, ..., N) := Expr; -- multi dimensional update
6645 if Is_Array_Type
(Typ
) then
6647 -- The index expressions of a multi dimensional array update
6648 -- appear as an aggregate.
6650 if Nkind
(Comp
) = N_Aggregate
then
6651 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
6653 Exprs
:= New_List
(Relocate_Node
(Comp
));
6657 Make_Indexed_Component
(Loc
,
6658 Prefix
=> New_Reference_To
(Temp
, Loc
),
6659 Expressions
=> Exprs
);
6661 -- A record component update appears in the following form:
6665 -- The above relation is transformed into an assignment statement
6666 -- where the left hand side is a selected component:
6668 -- Temp.Comp := Expr;
6670 else pragma Assert
(Is_Record_Type
(Typ
));
6672 Make_Selected_Component
(Loc
,
6673 Prefix
=> New_Reference_To
(Temp
, Loc
),
6674 Selector_Name
=> Relocate_Node
(Comp
));
6678 Make_Assignment_Statement
(Loc
,
6680 Expression
=> Relocate_Node
(Expr
)));
6681 end Process_Component_Or_Element_Update
;
6683 --------------------------
6684 -- Process_Range_Update --
6685 --------------------------
6687 procedure Process_Range_Update
6692 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
6696 -- A range update appears as
6698 -- (Low .. High => Expr)
6700 -- The above construct is transformed into a loop that iterates over
6701 -- the given range and modifies the corresponding array values to the
6704 -- for Index in Low .. High loop
6705 -- Temp (Index) := Expr;
6708 Index
:= Make_Temporary
(Loc
, 'I');
6711 Make_Loop_Statement
(Loc
,
6713 Make_Iteration_Scheme
(Loc
,
6714 Loop_Parameter_Specification
=>
6715 Make_Loop_Parameter_Specification
(Loc
,
6716 Defining_Identifier
=> Index
,
6717 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
6719 Statements
=> New_List
(
6720 Make_Assignment_Statement
(Loc
,
6722 Make_Indexed_Component
(Loc
,
6723 Prefix
=> New_Reference_To
(Temp
, Loc
),
6724 Expressions
=> New_List
(New_Reference_To
(Index
, Loc
))),
6725 Expression
=> Relocate_Node
(Expr
))),
6727 End_Label
=> Empty
));
6728 end Process_Range_Update
;
6732 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
6733 Loc
: constant Source_Ptr
:= Sloc
(N
);
6734 Pref
: constant Node_Id
:= Prefix
(N
);
6735 Typ
: constant Entity_Id
:= Etype
(Pref
);
6741 -- Start of processing for Expand_Update_Attribute
6744 -- Create the anonymous object that stores the value of the prefix and
6745 -- reflects subsequent changes in value. Generate:
6747 -- Temp : <type of Pref> := Pref;
6749 Temp
:= Make_Temporary
(Loc
, 'T');
6752 Make_Object_Declaration
(Loc
,
6753 Defining_Identifier
=> Temp
,
6754 Object_Definition
=> New_Reference_To
(Typ
, Loc
),
6755 Expression
=> Relocate_Node
(Pref
)));
6757 -- Process the update aggregate
6759 Assoc
:= First
(Component_Associations
(Aggr
));
6760 while Present
(Assoc
) loop
6761 Comp
:= First
(Choices
(Assoc
));
6762 Expr
:= Expression
(Assoc
);
6763 while Present
(Comp
) loop
6764 if Nkind
(Comp
) = N_Range
then
6765 Process_Range_Update
(Temp
, Comp
, Expr
);
6767 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
6776 -- The attribute is replaced by a reference to the anonymous object
6778 Rewrite
(N
, New_Reference_To
(Temp
, Loc
));
6780 end Expand_Update_Attribute
;
6786 procedure Find_Fat_Info
6788 Fat_Type
: out Entity_Id
;
6789 Fat_Pkg
: out RE_Id
)
6791 Btyp
: constant Entity_Id
:= Base_Type
(T
);
6792 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
6793 Digs
: constant Nat
:= UI_To_Int
(Digits_Value
(Btyp
));
6796 -- If the base type is VAX float, then get appropriate VAX float type
6798 if Vax_Float
(Btyp
) then
6801 Fat_Type
:= RTE
(RE_Fat_VAX_F
);
6802 Fat_Pkg
:= RE_Attr_VAX_F_Float
;
6805 Fat_Type
:= RTE
(RE_Fat_VAX_D
);
6806 Fat_Pkg
:= RE_Attr_VAX_D_Float
;
6809 Fat_Type
:= RTE
(RE_Fat_VAX_G
);
6810 Fat_Pkg
:= RE_Attr_VAX_G_Float
;
6813 raise Program_Error
;
6816 -- If root type is VAX float, this is the case where the library has
6817 -- been recompiled in VAX float mode, and we have an IEEE float type.
6818 -- This is when we use the special IEEE Fat packages.
6820 elsif Vax_Float
(Rtyp
) then
6823 Fat_Type
:= RTE
(RE_Fat_IEEE_Short
);
6824 Fat_Pkg
:= RE_Attr_IEEE_Short
;
6827 Fat_Type
:= RTE
(RE_Fat_IEEE_Long
);
6828 Fat_Pkg
:= RE_Attr_IEEE_Long
;
6831 raise Program_Error
;
6834 -- If neither the base type nor the root type is VAX_Native then VAX
6835 -- float is out of the picture, and we can just use the root type.
6840 if Fat_Type
= Standard_Short_Float
then
6841 Fat_Pkg
:= RE_Attr_Short_Float
;
6843 elsif Fat_Type
= Standard_Float
then
6844 Fat_Pkg
:= RE_Attr_Float
;
6846 elsif Fat_Type
= Standard_Long_Float
then
6847 Fat_Pkg
:= RE_Attr_Long_Float
;
6849 elsif Fat_Type
= Standard_Long_Long_Float
then
6850 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
6852 -- Universal real (which is its own root type) is treated as being
6853 -- equivalent to Standard.Long_Long_Float, since it is defined to
6854 -- have the same precision as the longest Float type.
6856 elsif Fat_Type
= Universal_Real
then
6857 Fat_Type
:= Standard_Long_Long_Float
;
6858 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
6861 raise Program_Error
;
6866 ----------------------------
6867 -- Find_Stream_Subprogram --
6868 ----------------------------
6870 function Find_Stream_Subprogram
6872 Nam
: TSS_Name_Type
) return Entity_Id
6874 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
6875 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
6877 function Is_Available
(Entity
: RE_Id
) return Boolean;
6878 pragma Inline
(Is_Available
);
6879 -- Function to check whether the specified run-time call is available
6880 -- in the run time used. In the case of a configurable run time, it
6881 -- is normal that some subprograms are not there.
6883 -- I don't understand this routine at all, why is this not just a
6884 -- call to RTE_Available? And if for some reason we need a different
6885 -- routine with different semantics, why is not in Rtsfind ???
6891 function Is_Available
(Entity
: RE_Id
) return Boolean is
6893 -- Assume that the unit will always be available when using a
6894 -- "normal" (not configurable) run time.
6896 return not Configurable_Run_Time_Mode
6897 or else RTE_Available
(Entity
);
6900 -- Start of processing for Find_Stream_Subprogram
6903 if Present
(Ent
) then
6907 -- Stream attributes for strings are expanded into library calls. The
6908 -- following checks are disabled when the run-time is not available or
6909 -- when compiling predefined types due to bootstrap issues. As a result,
6910 -- the compiler will generate in-place stream routines for string types
6911 -- that appear in GNAT's library, but will generate calls via rtsfind
6912 -- to library routines for user code.
6914 -- ??? For now, disable this code for JVM, since this generates a
6915 -- VerifyError exception at run time on e.g. c330001.
6917 -- This is disabled for AAMP, to avoid creating dependences on files not
6918 -- supported in the AAMP library (such as s-fileio.adb).
6920 -- Note: In the case of using a configurable run time, it is very likely
6921 -- that stream routines for string types are not present (they require
6922 -- file system support). In this case, the specific stream routines for
6923 -- strings are not used, relying on the regular stream mechanism
6924 -- instead. That is why we include the test Is_Available when dealing
6925 -- with these cases.
6927 if VM_Target
/= JVM_Target
6928 and then not AAMP_On_Target
6930 not Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
6932 -- String as defined in package Ada
6934 if Base_Typ
= Standard_String
then
6935 if Restriction_Active
(No_Stream_Optimizations
) then
6936 if Nam
= TSS_Stream_Input
6937 and then Is_Available
(RE_String_Input
)
6939 return RTE
(RE_String_Input
);
6941 elsif Nam
= TSS_Stream_Output
6942 and then Is_Available
(RE_String_Output
)
6944 return RTE
(RE_String_Output
);
6946 elsif Nam
= TSS_Stream_Read
6947 and then Is_Available
(RE_String_Read
)
6949 return RTE
(RE_String_Read
);
6951 elsif Nam
= TSS_Stream_Write
6952 and then Is_Available
(RE_String_Write
)
6954 return RTE
(RE_String_Write
);
6956 elsif Nam
/= TSS_Stream_Input
and then
6957 Nam
/= TSS_Stream_Output
and then
6958 Nam
/= TSS_Stream_Read
and then
6959 Nam
/= TSS_Stream_Write
6961 raise Program_Error
;
6965 if Nam
= TSS_Stream_Input
6966 and then Is_Available
(RE_String_Input_Blk_IO
)
6968 return RTE
(RE_String_Input_Blk_IO
);
6970 elsif Nam
= TSS_Stream_Output
6971 and then Is_Available
(RE_String_Output_Blk_IO
)
6973 return RTE
(RE_String_Output_Blk_IO
);
6975 elsif Nam
= TSS_Stream_Read
6976 and then Is_Available
(RE_String_Read_Blk_IO
)
6978 return RTE
(RE_String_Read_Blk_IO
);
6980 elsif Nam
= TSS_Stream_Write
6981 and then Is_Available
(RE_String_Write_Blk_IO
)
6983 return RTE
(RE_String_Write_Blk_IO
);
6985 elsif Nam
/= TSS_Stream_Input
and then
6986 Nam
/= TSS_Stream_Output
and then
6987 Nam
/= TSS_Stream_Read
and then
6988 Nam
/= TSS_Stream_Write
6990 raise Program_Error
;
6994 -- Wide_String as defined in package Ada
6996 elsif Base_Typ
= Standard_Wide_String
then
6997 if Restriction_Active
(No_Stream_Optimizations
) then
6998 if Nam
= TSS_Stream_Input
6999 and then Is_Available
(RE_Wide_String_Input
)
7001 return RTE
(RE_Wide_String_Input
);
7003 elsif Nam
= TSS_Stream_Output
7004 and then Is_Available
(RE_Wide_String_Output
)
7006 return RTE
(RE_Wide_String_Output
);
7008 elsif Nam
= TSS_Stream_Read
7009 and then Is_Available
(RE_Wide_String_Read
)
7011 return RTE
(RE_Wide_String_Read
);
7013 elsif Nam
= TSS_Stream_Write
7014 and then Is_Available
(RE_Wide_String_Write
)
7016 return RTE
(RE_Wide_String_Write
);
7018 elsif Nam
/= TSS_Stream_Input
and then
7019 Nam
/= TSS_Stream_Output
and then
7020 Nam
/= TSS_Stream_Read
and then
7021 Nam
/= TSS_Stream_Write
7023 raise Program_Error
;
7027 if Nam
= TSS_Stream_Input
7028 and then Is_Available
(RE_Wide_String_Input_Blk_IO
)
7030 return RTE
(RE_Wide_String_Input_Blk_IO
);
7032 elsif Nam
= TSS_Stream_Output
7033 and then Is_Available
(RE_Wide_String_Output_Blk_IO
)
7035 return RTE
(RE_Wide_String_Output_Blk_IO
);
7037 elsif Nam
= TSS_Stream_Read
7038 and then Is_Available
(RE_Wide_String_Read_Blk_IO
)
7040 return RTE
(RE_Wide_String_Read_Blk_IO
);
7042 elsif Nam
= TSS_Stream_Write
7043 and then Is_Available
(RE_Wide_String_Write_Blk_IO
)
7045 return RTE
(RE_Wide_String_Write_Blk_IO
);
7047 elsif Nam
/= TSS_Stream_Input
and then
7048 Nam
/= TSS_Stream_Output
and then
7049 Nam
/= TSS_Stream_Read
and then
7050 Nam
/= TSS_Stream_Write
7052 raise Program_Error
;
7056 -- Wide_Wide_String as defined in package Ada
7058 elsif Base_Typ
= Standard_Wide_Wide_String
then
7059 if Restriction_Active
(No_Stream_Optimizations
) then
7060 if Nam
= TSS_Stream_Input
7061 and then Is_Available
(RE_Wide_Wide_String_Input
)
7063 return RTE
(RE_Wide_Wide_String_Input
);
7065 elsif Nam
= TSS_Stream_Output
7066 and then Is_Available
(RE_Wide_Wide_String_Output
)
7068 return RTE
(RE_Wide_Wide_String_Output
);
7070 elsif Nam
= TSS_Stream_Read
7071 and then Is_Available
(RE_Wide_Wide_String_Read
)
7073 return RTE
(RE_Wide_Wide_String_Read
);
7075 elsif Nam
= TSS_Stream_Write
7076 and then Is_Available
(RE_Wide_Wide_String_Write
)
7078 return RTE
(RE_Wide_Wide_String_Write
);
7080 elsif Nam
/= TSS_Stream_Input
and then
7081 Nam
/= TSS_Stream_Output
and then
7082 Nam
/= TSS_Stream_Read
and then
7083 Nam
/= TSS_Stream_Write
7085 raise Program_Error
;
7089 if Nam
= TSS_Stream_Input
7090 and then Is_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
7092 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
7094 elsif Nam
= TSS_Stream_Output
7095 and then Is_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
7097 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
7099 elsif Nam
= TSS_Stream_Read
7100 and then Is_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
7102 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
7104 elsif Nam
= TSS_Stream_Write
7105 and then Is_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
7107 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
7109 elsif Nam
/= TSS_Stream_Input
and then
7110 Nam
/= TSS_Stream_Output
and then
7111 Nam
/= TSS_Stream_Read
and then
7112 Nam
/= TSS_Stream_Write
7114 raise Program_Error
;
7120 if Is_Tagged_Type
(Typ
)
7121 and then Is_Derived_Type
(Typ
)
7123 return Find_Prim_Op
(Typ
, Nam
);
7125 return Find_Inherited_TSS
(Typ
, Nam
);
7127 end Find_Stream_Subprogram
;
7133 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
7137 BT
:= Base_Type
(T
);
7139 if Is_Private_Type
(BT
)
7140 and then Present
(Full_View
(BT
))
7142 BT
:= Full_View
(BT
);
7148 -----------------------
7149 -- Get_Index_Subtype --
7150 -----------------------
7152 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
7153 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
7158 if Is_Access_Type
(P_Type
) then
7159 P_Type
:= Designated_Type
(P_Type
);
7162 if No
(Expressions
(N
)) then
7165 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
7168 Indx
:= First_Index
(P_Type
);
7174 return Etype
(Indx
);
7175 end Get_Index_Subtype
;
7177 -------------------------------
7178 -- Get_Stream_Convert_Pragma --
7179 -------------------------------
7181 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
7186 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
7187 -- that a stream convert pragma for a tagged type is not inherited from
7188 -- its parent. Probably what is wrong here is that it is basically
7189 -- incorrect to consider a stream convert pragma to be a representation
7190 -- pragma at all ???
7192 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
7193 while Present
(N
) loop
7194 if Nkind
(N
) = N_Pragma
7195 and then Pragma_Name
(N
) = Name_Stream_Convert
7197 -- For tagged types this pragma is not inherited, so we
7198 -- must verify that it is defined for the given type and
7202 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
7204 if not Is_Tagged_Type
(T
)
7206 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
7216 end Get_Stream_Convert_Pragma
;
7218 ---------------------------------
7219 -- Is_Constrained_Packed_Array --
7220 ---------------------------------
7222 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
7223 Arr
: Entity_Id
:= Typ
;
7226 if Is_Access_Type
(Arr
) then
7227 Arr
:= Designated_Type
(Arr
);
7230 return Is_Array_Type
(Arr
)
7231 and then Is_Constrained
(Arr
)
7232 and then Present
(Packed_Array_Type
(Arr
));
7233 end Is_Constrained_Packed_Array
;
7235 ----------------------------------------
7236 -- Is_Inline_Floating_Point_Attribute --
7237 ----------------------------------------
7239 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
7240 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
7243 if Nkind
(Parent
(N
)) /= N_Type_Conversion
7244 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
7249 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
7250 -- required back end support has not been implemented yet ???
7252 return Id
= Attribute_Truncation
;
7253 end Is_Inline_Floating_Point_Attribute
;