1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, 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. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Exp_Atag
; use Exp_Atag
;
32 with Exp_Ch2
; use Exp_Ch2
;
33 with Exp_Ch3
; use Exp_Ch3
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch9
; use Exp_Ch9
;
36 with Exp_Dist
; use Exp_Dist
;
37 with Exp_Imgv
; use Exp_Imgv
;
38 with Exp_Pakd
; use Exp_Pakd
;
39 with Exp_Strm
; use Exp_Strm
;
40 with Exp_Tss
; use Exp_Tss
;
41 with Exp_Util
; use Exp_Util
;
42 with Exp_VFpt
; use Exp_VFpt
;
43 with Fname
; use Fname
;
44 with Freeze
; use Freeze
;
45 with Gnatvsn
; use Gnatvsn
;
46 with Itypes
; use Itypes
;
48 with Namet
; use Namet
;
49 with Nmake
; use Nmake
;
50 with Nlists
; use Nlists
;
52 with Restrict
; use Restrict
;
53 with Rident
; use Rident
;
54 with Rtsfind
; use Rtsfind
;
56 with Sem_Aux
; use Sem_Aux
;
57 with Sem_Ch6
; use Sem_Ch6
;
58 with Sem_Ch7
; use Sem_Ch7
;
59 with Sem_Ch8
; use Sem_Ch8
;
60 with Sem_Eval
; use Sem_Eval
;
61 with Sem_Res
; use Sem_Res
;
62 with Sem_Util
; use Sem_Util
;
63 with Sinfo
; use Sinfo
;
64 with Snames
; use Snames
;
65 with Stand
; use Stand
;
66 with Stringt
; use Stringt
;
67 with Targparm
; use Targparm
;
68 with Tbuild
; use Tbuild
;
69 with Ttypes
; use Ttypes
;
70 with Uintp
; use Uintp
;
71 with Uname
; use Uname
;
72 with Validsw
; use Validsw
;
74 package body Exp_Attr
is
76 -----------------------
77 -- Local Subprograms --
78 -----------------------
80 procedure Compile_Stream_Body_In_Scope
85 -- The body for a stream subprogram may be generated outside of the scope
86 -- of the type. If the type is fully private, it may depend on the full
87 -- view of other types (e.g. indices) that are currently private as well.
88 -- We install the declarations of the package in which the type is declared
89 -- before compiling the body in what is its proper environment. The Check
90 -- parameter indicates if checks are to be suppressed for the stream body.
91 -- We suppress checks for array/record reads, since the rule is that these
92 -- are like assignments, out of range values due to uninitialized storage,
93 -- or other invalid values do NOT cause a Constraint_Error to be raised.
95 procedure Expand_Access_To_Protected_Op
99 -- An attribute reference to a protected subprogram is transformed into
100 -- a pair of pointers: one to the object, and one to the operations.
101 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
103 procedure Expand_Fpt_Attribute
108 -- This procedure expands a call to a floating-point attribute function.
109 -- N is the attribute reference node, and Args is a list of arguments to
110 -- be passed to the function call. Pkg identifies the package containing
111 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
112 -- have already been converted to the floating-point type for which Pkg was
113 -- instantiated. The Nam argument is the relevant attribute processing
114 -- routine to be called. This is the same as the attribute name, except in
115 -- the Unaligned_Valid case.
117 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
118 -- This procedure expands a call to a floating-point attribute function
119 -- that takes a single floating-point argument. The function to be called
120 -- is always the same as the attribute name.
122 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
123 -- This procedure expands a call to a floating-point attribute function
124 -- that takes one floating-point argument and one integer argument. The
125 -- function to be called is always the same as the attribute name.
127 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
128 -- This procedure expands a call to a floating-point attribute function
129 -- that takes two floating-point arguments. The function to be called
130 -- is always the same as the attribute name.
132 procedure Expand_Pred_Succ
(N
: Node_Id
);
133 -- Handles expansion of Pred or Succ attributes for case of non-real
134 -- operand with overflow checking required.
136 function Get_Index_Subtype
(N
: Node_Id
) return Entity_Id
;
137 -- Used for Last, Last, and Length, when the prefix is an array type.
138 -- Obtains the corresponding index subtype.
140 procedure Find_Fat_Info
142 Fat_Type
: out Entity_Id
;
143 Fat_Pkg
: out RE_Id
);
144 -- Given a floating-point type T, identifies the package containing the
145 -- attributes for this type (returned in Fat_Pkg), and the corresponding
146 -- type for which this package was instantiated from Fat_Gen. Error if T
147 -- is not a floating-point type.
149 function Find_Stream_Subprogram
151 Nam
: TSS_Name_Type
) return Entity_Id
;
152 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
153 -- types, the corresponding primitive operation is looked up, else the
154 -- appropriate TSS from the type itself, or from its closest ancestor
155 -- defining it, is returned. In both cases, inheritance of representation
156 -- aspects is thus taken into account.
158 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
159 -- The stream functions need to examine the underlying representation of
160 -- composite types. In some cases T may be non-private but its base type
161 -- is, in which case the function returns the corresponding full view.
163 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
164 -- Given a type, find a corresponding stream convert pragma that applies to
165 -- the implementation base type of this type (Typ). If found, return the
166 -- pragma node, otherwise return Empty if no pragma is found.
168 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
169 -- Utility for array attributes, returns true on packed constrained
170 -- arrays, and on access to same.
172 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
173 -- Returns true iff the given node refers to an attribute call that
174 -- can be expanded directly by the back end and does not need front end
175 -- expansion. Typically used for rounding and truncation attributes that
176 -- appear directly inside a conversion to integer.
178 ----------------------------------
179 -- Compile_Stream_Body_In_Scope --
180 ----------------------------------
182 procedure Compile_Stream_Body_In_Scope
188 Installed
: Boolean := False;
189 Scop
: constant Entity_Id
:= Scope
(Arr
);
190 Curr
: constant Entity_Id
:= Current_Scope
;
194 and then not In_Open_Scopes
(Scop
)
195 and then Ekind
(Scop
) = E_Package
198 Install_Visible_Declarations
(Scop
);
199 Install_Private_Declarations
(Scop
);
202 -- The entities in the package are now visible, but the generated
203 -- stream entity must appear in the current scope (usually an
204 -- enclosing stream function) so that itypes all have their proper
211 Insert_Action
(N
, Decl
);
213 Insert_Action
(N
, Decl
, Suppress
=> All_Checks
);
218 -- Remove extra copy of current scope, and package itself
221 End_Package_Scope
(Scop
);
223 end Compile_Stream_Body_In_Scope
;
225 -----------------------------------
226 -- Expand_Access_To_Protected_Op --
227 -----------------------------------
229 procedure Expand_Access_To_Protected_Op
234 -- The value of the attribute_reference is a record containing two
235 -- fields: an access to the protected object, and an access to the
236 -- subprogram itself. The prefix is a selected component.
238 Loc
: constant Source_Ptr
:= Sloc
(N
);
240 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
243 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
244 Acc
: constant Entity_Id
:=
245 Etype
(Next_Component
(First_Component
(E_T
)));
249 function May_Be_External_Call
return Boolean;
250 -- If the 'Access is to a local operation, but appears in a context
251 -- where it may lead to a call from outside the object, we must treat
252 -- this as an external call. Clearly we cannot tell without full
253 -- flow analysis, and a subsequent call that uses this 'Access may
254 -- lead to a bounded error (trying to seize locks twice, e.g.). For
255 -- now we treat 'Access as a potential external call if it is an actual
256 -- in a call to an outside subprogram.
258 --------------------------
259 -- May_Be_External_Call --
260 --------------------------
262 function May_Be_External_Call
return Boolean is
264 Par
: Node_Id
:= Parent
(N
);
267 -- Account for the case where the Access attribute is part of a
268 -- named parameter association.
270 if Nkind
(Par
) = N_Parameter_Association
then
274 if Nkind_In
(Par
, N_Procedure_Call_Statement
, N_Function_Call
)
275 and then Is_Entity_Name
(Name
(Par
))
277 Subp
:= Entity
(Name
(Par
));
278 return not In_Open_Scopes
(Scope
(Subp
));
282 end May_Be_External_Call
;
284 -- Start of processing for Expand_Access_To_Protected_Op
287 -- Within the body of the protected type, the prefix designates a local
288 -- operation, and the object is the first parameter of the corresponding
289 -- protected body of the current enclosing operation.
291 if Is_Entity_Name
(Pref
) then
292 if May_Be_External_Call
then
294 New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
298 (Protected_Body_Subprogram
(Entity
(Pref
)), Loc
);
301 -- Don't traverse the scopes when the attribute occurs within an init
302 -- proc, because we directly use the _init formal of the init proc in
305 Curr
:= Current_Scope
;
306 if not Is_Init_Proc
(Curr
) then
307 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
309 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
310 Curr
:= Scope
(Curr
);
314 -- In case of protected entries the first formal of its Protected_
315 -- Body_Subprogram is the address of the object.
317 if Ekind
(Curr
) = E_Entry
then
321 (Protected_Body_Subprogram
(Curr
)), Loc
);
323 -- If the current scope is an init proc, then use the address of the
324 -- _init formal as the object reference.
326 elsif Is_Init_Proc
(Curr
) then
328 Make_Attribute_Reference
(Loc
,
329 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
330 Attribute_Name
=> Name_Address
);
332 -- In case of protected subprograms the first formal of its
333 -- Protected_Body_Subprogram is the object and we get its address.
337 Make_Attribute_Reference
(Loc
,
341 (Protected_Body_Subprogram
(Curr
)), Loc
),
342 Attribute_Name
=> Name_Address
);
345 -- Case where the prefix is not an entity name. Find the
346 -- version of the protected operation to be called from
347 -- outside the protected object.
353 (Entity
(Selector_Name
(Pref
))), Loc
);
356 Make_Attribute_Reference
(Loc
,
357 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
358 Attribute_Name
=> Name_Address
);
362 Make_Attribute_Reference
(Loc
,
364 Attribute_Name
=> Name_Access
);
366 -- We set the type of the access reference to the already generated
367 -- access_to_subprogram type, and declare the reference analyzed, to
368 -- prevent further expansion when the enclosing aggregate is analyzed.
370 Set_Etype
(Sub_Ref
, Acc
);
371 Set_Analyzed
(Sub_Ref
);
375 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
377 -- Sub_Ref has been marked as analyzed, but we still need to make sure
378 -- Sub is correctly frozen.
380 Freeze_Before
(N
, Entity
(Sub
));
383 Analyze_And_Resolve
(N
, E_T
);
385 -- For subsequent analysis, the node must retain its type. The backend
386 -- will replace it with the equivalent type where needed.
389 end Expand_Access_To_Protected_Op
;
391 --------------------------
392 -- Expand_Fpt_Attribute --
393 --------------------------
395 procedure Expand_Fpt_Attribute
401 Loc
: constant Source_Ptr
:= Sloc
(N
);
402 Typ
: constant Entity_Id
:= Etype
(N
);
406 -- The function name is the selected component Attr_xxx.yyy where
407 -- Attr_xxx is the package name, and yyy is the argument Nam.
409 -- Note: it would be more usual to have separate RE entries for each
410 -- of the entities in the Fat packages, but first they have identical
411 -- names (so we would have to have lots of renaming declarations to
412 -- meet the normal RE rule of separate names for all runtime entities),
413 -- and second there would be an awful lot of them!
416 Make_Selected_Component
(Loc
,
417 Prefix
=> New_Reference_To
(RTE
(Pkg
), Loc
),
418 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
420 -- The generated call is given the provided set of parameters, and then
421 -- wrapped in a conversion which converts the result to the target type
422 -- We use the base type as the target because a range check may be
426 Unchecked_Convert_To
(Base_Type
(Etype
(N
)),
427 Make_Function_Call
(Loc
,
429 Parameter_Associations
=> Args
)));
431 Analyze_And_Resolve
(N
, Typ
);
432 end Expand_Fpt_Attribute
;
434 ----------------------------
435 -- Expand_Fpt_Attribute_R --
436 ----------------------------
438 -- The single argument is converted to its root type to call the
439 -- appropriate runtime function, with the actual call being built
440 -- by Expand_Fpt_Attribute
442 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
443 E1
: constant Node_Id
:= First
(Expressions
(N
));
447 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
449 (N
, Pkg
, Attribute_Name
(N
),
450 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
451 end Expand_Fpt_Attribute_R
;
453 -----------------------------
454 -- Expand_Fpt_Attribute_RI --
455 -----------------------------
457 -- The first argument is converted to its root type and the second
458 -- argument is converted to standard long long integer to call the
459 -- appropriate runtime function, with the actual call being built
460 -- by Expand_Fpt_Attribute
462 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
463 E1
: constant Node_Id
:= First
(Expressions
(N
));
466 E2
: constant Node_Id
:= Next
(E1
);
468 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
470 (N
, Pkg
, Attribute_Name
(N
),
472 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
473 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
474 end Expand_Fpt_Attribute_RI
;
476 -----------------------------
477 -- Expand_Fpt_Attribute_RR --
478 -----------------------------
480 -- The two arguments are converted to their root types to call the
481 -- appropriate runtime function, with the actual call being built
482 -- by Expand_Fpt_Attribute
484 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
485 E1
: constant Node_Id
:= First
(Expressions
(N
));
488 E2
: constant Node_Id
:= Next
(E1
);
490 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
492 (N
, Pkg
, Attribute_Name
(N
),
494 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
495 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
496 end Expand_Fpt_Attribute_RR
;
498 ----------------------------------
499 -- Expand_N_Attribute_Reference --
500 ----------------------------------
502 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
503 Loc
: constant Source_Ptr
:= Sloc
(N
);
504 Typ
: constant Entity_Id
:= Etype
(N
);
505 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
506 Pref
: constant Node_Id
:= Prefix
(N
);
507 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
508 Exprs
: constant List_Id
:= Expressions
(N
);
509 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
511 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
);
512 -- Rewrites a stream attribute for Read, Write or Output with the
513 -- procedure call. Pname is the entity for the procedure to call.
515 ------------------------------
516 -- Rewrite_Stream_Proc_Call --
517 ------------------------------
519 procedure Rewrite_Stream_Proc_Call
(Pname
: Entity_Id
) is
520 Item
: constant Node_Id
:= Next
(First
(Exprs
));
521 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
522 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
523 Is_Written
: constant Boolean := (Ekind
(Formal
) /= E_In_Parameter
);
526 -- The expansion depends on Item, the second actual, which is
527 -- the object being streamed in or out.
529 -- If the item is a component of a packed array type, and
530 -- a conversion is needed on exit, we introduce a temporary to
531 -- hold the value, because otherwise the packed reference will
532 -- not be properly expanded.
534 if Nkind
(Item
) = N_Indexed_Component
535 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
536 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
540 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
546 Make_Object_Declaration
(Loc
,
547 Defining_Identifier
=> Temp
,
549 New_Occurrence_Of
(Formal_Typ
, Loc
));
550 Set_Etype
(Temp
, Formal_Typ
);
553 Make_Assignment_Statement
(Loc
,
554 Name
=> New_Copy_Tree
(Item
),
557 (Etype
(Item
), New_Occurrence_Of
(Temp
, Loc
)));
559 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
563 Make_Procedure_Call_Statement
(Loc
,
564 Name
=> New_Occurrence_Of
(Pname
, Loc
),
565 Parameter_Associations
=> Exprs
),
568 Rewrite
(N
, Make_Null_Statement
(Loc
));
573 -- For the class-wide dispatching cases, and for cases in which
574 -- the base type of the second argument matches the base type of
575 -- the corresponding formal parameter (that is to say the stream
576 -- operation is not inherited), we are all set, and can use the
577 -- argument unchanged.
579 -- For all other cases we do an unchecked conversion of the second
580 -- parameter to the type of the formal of the procedure we are
581 -- calling. This deals with the private type cases, and with going
582 -- to the root type as required in elementary type case.
584 if not Is_Class_Wide_Type
(Entity
(Pref
))
585 and then not Is_Class_Wide_Type
(Etype
(Item
))
586 and then Base_Type
(Etype
(Item
)) /= Base_Type
(Formal_Typ
)
589 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
591 -- For untagged derived types set Assignment_OK, to prevent
592 -- copies from being created when the unchecked conversion
593 -- is expanded (which would happen in Remove_Side_Effects
594 -- if Expand_N_Unchecked_Conversion were allowed to call
595 -- Force_Evaluation). The copy could violate Ada semantics
596 -- in cases such as an actual that is an out parameter.
597 -- Note that this approach is also used in exp_ch7 for calls
598 -- to controlled type operations to prevent problems with
599 -- actuals wrapped in unchecked conversions.
601 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
602 Set_Assignment_OK
(Item
);
606 -- The stream operation to call maybe a renaming created by
607 -- an attribute definition clause, and may not be frozen yet.
608 -- Ensure that it has the necessary extra formals.
610 if not Is_Frozen
(Pname
) then
611 Create_Extra_Formals
(Pname
);
614 -- And now rewrite the call
617 Make_Procedure_Call_Statement
(Loc
,
618 Name
=> New_Occurrence_Of
(Pname
, Loc
),
619 Parameter_Associations
=> Exprs
));
622 end Rewrite_Stream_Proc_Call
;
624 -- Start of processing for Expand_N_Attribute_Reference
627 -- Do required validity checking, if enabled. Do not apply check to
628 -- output parameters of an Asm instruction, since the value of this
629 -- is not set till after the attribute has been elaborated, and do
630 -- not apply the check to the arguments of a 'Read or 'Input attribute
631 -- reference since the scalar argument is an OUT scalar.
633 if Validity_Checks_On
and then Validity_Check_Operands
634 and then Id
/= Attribute_Asm_Output
635 and then Id
/= Attribute_Read
636 and then Id
/= Attribute_Input
641 Expr
:= First
(Expressions
(N
));
642 while Present
(Expr
) loop
649 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
650 -- place function, then a temporary return object needs to be created
651 -- and access to it must be passed to the function. Currently we limit
652 -- such functions to those with inherently limited result subtypes, but
653 -- eventually we plan to expand the functions that are treated as
654 -- build-in-place to include other composite result types.
656 if Ada_Version
>= Ada_2005
657 and then Is_Build_In_Place_Function_Call
(Pref
)
659 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
662 -- If prefix is a protected type name, this is a reference to the
663 -- current instance of the type. For a component definition, nothing
664 -- to do (expansion will occur in the init proc). In other contexts,
665 -- rewrite into reference to current instance.
667 if Is_Protected_Self_Reference
(Pref
)
669 (Nkind_In
(Parent
(N
), N_Index_Or_Discriminant_Constraint
,
670 N_Discriminant_Association
)
671 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
672 N_Component_Definition
)
674 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
678 -- Remaining processing depends on specific attribute
686 when Attribute_Access |
687 Attribute_Unchecked_Access |
688 Attribute_Unrestricted_Access
=>
690 Access_Cases
: declare
691 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
692 Btyp_DDT
: Entity_Id
;
694 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
695 -- If N denotes a compound name (selected component, indexed
696 -- component, or slice), returns the name of the outermost such
697 -- enclosing object. Otherwise returns N. If the object is a
698 -- renaming, then the renamed object is returned.
700 ----------------------
701 -- Enclosing_Object --
702 ----------------------
704 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
709 while Nkind_In
(Obj_Name
, N_Selected_Component
,
713 Obj_Name
:= Prefix
(Obj_Name
);
716 return Get_Referenced_Object
(Obj_Name
);
717 end Enclosing_Object
;
719 -- Local declarations
721 Enc_Object
: constant Node_Id
:= Enclosing_Object
(Ref_Object
);
723 -- Start of processing for Access_Cases
726 Btyp_DDT
:= Designated_Type
(Btyp
);
728 -- Handle designated types that come from the limited view
730 if Ekind
(Btyp_DDT
) = E_Incomplete_Type
731 and then From_With_Type
(Btyp_DDT
)
732 and then Present
(Non_Limited_View
(Btyp_DDT
))
734 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
736 elsif Is_Class_Wide_Type
(Btyp_DDT
)
737 and then Ekind
(Etype
(Btyp_DDT
)) = E_Incomplete_Type
738 and then From_With_Type
(Etype
(Btyp_DDT
))
739 and then Present
(Non_Limited_View
(Etype
(Btyp_DDT
)))
740 and then Present
(Class_Wide_Type
741 (Non_Limited_View
(Etype
(Btyp_DDT
))))
744 Class_Wide_Type
(Non_Limited_View
(Etype
(Btyp_DDT
)));
747 -- In order to improve the text of error messages, the designated
748 -- type of access-to-subprogram itypes is set by the semantics as
749 -- the associated subprogram entity (see sem_attr). Now we replace
750 -- such node with the proper E_Subprogram_Type itype.
752 if Id
= Attribute_Unrestricted_Access
753 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
755 -- The following conditions ensure that this special management
756 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
757 -- At this stage other cases in which the designated type is
758 -- still a subprogram (instead of an E_Subprogram_Type) are
759 -- wrong because the semantics must have overridden the type of
760 -- the node with the type imposed by the context.
762 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
763 and then Etype
(Parent
(N
)) = RTE
(RE_Prim_Ptr
)
765 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
769 Subp
: constant Entity_Id
:=
770 Directly_Designated_Type
(Typ
);
772 Extra
: Entity_Id
:= Empty
;
773 New_Formal
: Entity_Id
;
774 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
775 Subp_Typ
: Entity_Id
;
778 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
779 Set_Etype
(Subp_Typ
, Etype
(Subp
));
780 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
782 if Present
(Old_Formal
) then
783 New_Formal
:= New_Copy
(Old_Formal
);
784 Set_First_Entity
(Subp_Typ
, New_Formal
);
787 Set_Scope
(New_Formal
, Subp_Typ
);
788 Etyp
:= Etype
(New_Formal
);
790 -- Handle itypes. There is no need to duplicate
791 -- here the itypes associated with record types
792 -- (i.e the implicit full view of private types).
795 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
797 Extra
:= New_Copy
(Etyp
);
798 Set_Parent
(Extra
, New_Formal
);
799 Set_Etype
(New_Formal
, Extra
);
800 Set_Scope
(Extra
, Subp_Typ
);
804 Next_Formal
(Old_Formal
);
805 exit when No
(Old_Formal
);
807 Set_Next_Entity
(New_Formal
,
808 New_Copy
(Old_Formal
));
809 Next_Entity
(New_Formal
);
812 Set_Next_Entity
(New_Formal
, Empty
);
813 Set_Last_Entity
(Subp_Typ
, Extra
);
816 -- Now that the explicit formals have been duplicated,
817 -- any extra formals needed by the subprogram must be
820 if Present
(Extra
) then
821 Set_Extra_Formal
(Extra
, Empty
);
824 Create_Extra_Formals
(Subp_Typ
);
825 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
830 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
831 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
833 -- If prefix is a type name, this is a reference to the current
834 -- instance of the type, within its initialization procedure.
836 elsif Is_Entity_Name
(Pref
)
837 and then Is_Type
(Entity
(Pref
))
844 -- If the current instance name denotes a task type, then
845 -- the access attribute is rewritten to be the name of the
846 -- "_task" parameter associated with the task type's task
847 -- procedure. An unchecked conversion is applied to ensure
848 -- a type match in cases of expander-generated calls (e.g.
851 if Is_Task_Type
(Entity
(Pref
)) then
853 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
854 while Present
(Formal
) loop
855 exit when Chars
(Formal
) = Name_uTask
;
856 Next_Entity
(Formal
);
859 pragma Assert
(Present
(Formal
));
862 Unchecked_Convert_To
(Typ
,
863 New_Occurrence_Of
(Formal
, Loc
)));
866 -- The expression must appear in a default expression,
867 -- (which in the initialization procedure is the
868 -- right-hand side of an assignment), and not in a
869 -- discriminant constraint.
873 while Present
(Par
) loop
874 exit when Nkind
(Par
) = N_Assignment_Statement
;
876 if Nkind
(Par
) = N_Component_Declaration
then
883 if Present
(Par
) then
885 Make_Attribute_Reference
(Loc
,
886 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
887 Attribute_Name
=> Attribute_Name
(N
)));
889 Analyze_And_Resolve
(N
, Typ
);
894 -- If the prefix of an Access attribute is a dereference of an
895 -- access parameter (or a renaming of such a dereference, or a
896 -- subcomponent of such a dereference) and the context is a
897 -- general access type (including the type of an object or
898 -- component with an access_definition, but not the anonymous
899 -- type of an access parameter or access discriminant), then
900 -- apply an accessibility check to the access parameter. We used
901 -- to rewrite the access parameter as a type conversion, but that
902 -- could only be done if the immediate prefix of the Access
903 -- attribute was the dereference, and didn't handle cases where
904 -- the attribute is applied to a subcomponent of the dereference,
905 -- since there's generally no available, appropriate access type
906 -- to convert to in that case. The attribute is passed as the
907 -- point to insert the check, because the access parameter may
908 -- come from a renaming, possibly in a different scope, and the
909 -- check must be associated with the attribute itself.
911 elsif Id
= Attribute_Access
912 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
913 and then Is_Entity_Name
(Prefix
(Enc_Object
))
914 and then (Ekind
(Btyp
) = E_General_Access_Type
915 or else Is_Local_Anonymous_Access
(Btyp
))
916 and then Ekind
(Entity
(Prefix
(Enc_Object
))) in Formal_Kind
917 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
918 = E_Anonymous_Access_Type
919 and then Present
(Extra_Accessibility
920 (Entity
(Prefix
(Enc_Object
))))
922 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
924 -- Ada 2005 (AI-251): If the designated type is an interface we
925 -- add an implicit conversion to force the displacement of the
926 -- pointer to reference the secondary dispatch table.
928 elsif Is_Interface
(Btyp_DDT
)
929 and then (Comes_From_Source
(N
)
930 or else Comes_From_Source
(Ref_Object
)
931 or else (Nkind
(Ref_Object
) in N_Has_Chars
932 and then Chars
(Ref_Object
) = Name_uInit
))
934 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
936 -- No implicit conversion required if types match, or if
937 -- the prefix is the class_wide_type of the interface. In
938 -- either case passing an object of the interface type has
939 -- already set the pointer correctly.
941 if Btyp_DDT
= Etype
(Ref_Object
)
942 or else (Is_Class_Wide_Type
(Etype
(Ref_Object
))
944 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
950 Convert_To
(Btyp_DDT
,
951 New_Copy_Tree
(Prefix
(N
))));
953 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
956 -- When the object is an explicit dereference, convert the
957 -- dereference's prefix.
961 Obj_DDT
: constant Entity_Id
:=
963 (Directly_Designated_Type
964 (Etype
(Prefix
(Ref_Object
))));
966 -- No implicit conversion required if designated types
969 if Obj_DDT
/= Btyp_DDT
970 and then not (Is_Class_Wide_Type
(Obj_DDT
)
971 and then Etype
(Obj_DDT
) = Btyp_DDT
)
975 New_Copy_Tree
(Prefix
(Ref_Object
))));
976 Analyze_And_Resolve
(N
, Typ
);
987 -- Transforms 'Adjacent into a call to the floating-point attribute
988 -- function Adjacent in Fat_xxx (where xxx is the root type)
990 when Attribute_Adjacent
=>
991 Expand_Fpt_Attribute_RR
(N
);
997 when Attribute_Address
=> Address
: declare
998 Task_Proc
: Entity_Id
;
1001 -- If the prefix is a task or a task type, the useful address is that
1002 -- of the procedure for the task body, i.e. the actual program unit.
1003 -- We replace the original entity with that of the procedure.
1005 if Is_Entity_Name
(Pref
)
1006 and then Is_Task_Type
(Entity
(Pref
))
1008 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
1010 while Present
(Task_Proc
) loop
1011 exit when Ekind
(Task_Proc
) = E_Procedure
1012 and then Etype
(First_Formal
(Task_Proc
)) =
1013 Corresponding_Record_Type
(Ptyp
);
1014 Next_Entity
(Task_Proc
);
1017 if Present
(Task_Proc
) then
1018 Set_Entity
(Pref
, Task_Proc
);
1019 Set_Etype
(Pref
, Etype
(Task_Proc
));
1022 -- Similarly, the address of a protected operation is the address
1023 -- of the corresponding protected body, regardless of the protected
1024 -- object from which it is selected.
1026 elsif Nkind
(Pref
) = N_Selected_Component
1027 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
1028 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
1032 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
1034 elsif Nkind
(Pref
) = N_Explicit_Dereference
1035 and then Ekind
(Ptyp
) = E_Subprogram_Type
1036 and then Convention
(Ptyp
) = Convention_Protected
1038 -- The prefix is be a dereference of an access_to_protected_
1039 -- subprogram. The desired address is the second component of
1040 -- the record that represents the access.
1043 Addr
: constant Entity_Id
:= Etype
(N
);
1044 Ptr
: constant Node_Id
:= Prefix
(Pref
);
1045 T
: constant Entity_Id
:=
1046 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
1050 Unchecked_Convert_To
(Addr
,
1051 Make_Selected_Component
(Loc
,
1052 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
1053 Selector_Name
=> New_Occurrence_Of
(
1054 Next_Entity
(First_Entity
(T
)), Loc
))));
1056 Analyze_And_Resolve
(N
, Addr
);
1059 -- Ada 2005 (AI-251): Class-wide interface objects are always
1060 -- "displaced" to reference the tag associated with the interface
1061 -- type. In order to obtain the real address of such objects we
1062 -- generate a call to a run-time subprogram that returns the base
1063 -- address of the object.
1065 -- This processing is not needed in the VM case, where dispatching
1066 -- issues are taken care of by the virtual machine.
1068 elsif Is_Class_Wide_Type
(Ptyp
)
1069 and then Is_Interface
(Ptyp
)
1070 and then Tagged_Type_Expansion
1071 and then not (Nkind
(Pref
) in N_Has_Entity
1072 and then Is_Subprogram
(Entity
(Pref
)))
1075 Make_Function_Call
(Loc
,
1076 Name
=> New_Reference_To
(RTE
(RE_Base_Address
), Loc
),
1077 Parameter_Associations
=> New_List
(
1078 Relocate_Node
(N
))));
1083 -- Deal with packed array reference, other cases are handled by
1086 if Involves_Packed_Array_Reference
(Pref
) then
1087 Expand_Packed_Address_Reference
(N
);
1095 when Attribute_Alignment
=> Alignment
: declare
1099 -- For class-wide types, X'Class'Alignment is transformed into a
1100 -- direct reference to the Alignment of the class type, so that the
1101 -- back end does not have to deal with the X'Class'Alignment
1104 if Is_Entity_Name
(Pref
)
1105 and then Is_Class_Wide_Type
(Entity
(Pref
))
1107 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
1110 -- For x'Alignment applied to an object of a class wide type,
1111 -- transform X'Alignment into a call to the predefined primitive
1112 -- operation _Alignment applied to X.
1114 elsif Is_Class_Wide_Type
(Ptyp
) then
1116 -- No need to do anything else compiling under restriction
1117 -- No_Dispatching_Calls. During the semantic analysis we
1118 -- already notified such violation.
1120 if Restriction_Active
(No_Dispatching_Calls
) then
1125 Make_Function_Call
(Loc
,
1126 Name
=> New_Reference_To
1127 (Find_Prim_Op
(Ptyp
, Name_uAlignment
), Loc
),
1128 Parameter_Associations
=> New_List
(Pref
));
1130 if Typ
/= Standard_Integer
then
1132 -- The context is a specific integer type with which the
1133 -- original attribute was compatible. The function has a
1134 -- specific type as well, so to preserve the compatibility
1135 -- we must convert explicitly.
1137 New_Node
:= Convert_To
(Typ
, New_Node
);
1140 Rewrite
(N
, New_Node
);
1141 Analyze_And_Resolve
(N
, Typ
);
1144 -- For all other cases, we just have to deal with the case of
1145 -- the fact that the result can be universal.
1148 Apply_Universal_Integer_Attribute_Checks
(N
);
1156 when Attribute_AST_Entry
=> AST_Entry
: declare
1161 Entry_Ref
: Node_Id
;
1162 -- The reference to the entry or entry family
1165 -- The index expression for an entry family reference, or
1166 -- the Empty if Entry_Ref references a simple entry.
1169 if Nkind
(Pref
) = N_Indexed_Component
then
1170 Entry_Ref
:= Prefix
(Pref
);
1171 Index
:= First
(Expressions
(Pref
));
1177 -- Get expression for Task_Id and the entry entity
1179 if Nkind
(Entry_Ref
) = N_Selected_Component
then
1181 Make_Attribute_Reference
(Loc
,
1182 Attribute_Name
=> Name_Identity
,
1183 Prefix
=> Prefix
(Entry_Ref
));
1185 Ttyp
:= Etype
(Prefix
(Entry_Ref
));
1186 Eent
:= Entity
(Selector_Name
(Entry_Ref
));
1190 Make_Function_Call
(Loc
,
1191 Name
=> New_Occurrence_Of
(RTE
(RE_Current_Task
), Loc
));
1193 Eent
:= Entity
(Entry_Ref
);
1195 -- We have to find the enclosing task to get the task type
1196 -- There must be one, since we already validated this earlier
1198 Ttyp
:= Current_Scope
;
1199 while not Is_Task_Type
(Ttyp
) loop
1200 Ttyp
:= Scope
(Ttyp
);
1204 -- Now rewrite the attribute with a call to Create_AST_Handler
1207 Make_Function_Call
(Loc
,
1208 Name
=> New_Occurrence_Of
(RTE
(RE_Create_AST_Handler
), Loc
),
1209 Parameter_Associations
=> New_List
(
1211 Entry_Index_Expression
(Loc
, Eent
, Index
, Ttyp
))));
1213 Analyze_And_Resolve
(N
, RTE
(RE_AST_Handler
));
1220 -- We compute this if a packed array reference was present, otherwise we
1221 -- leave the computation up to the back end.
1223 when Attribute_Bit
=>
1224 if Involves_Packed_Array_Reference
(Pref
) then
1225 Expand_Packed_Bit_Reference
(N
);
1227 Apply_Universal_Integer_Attribute_Checks
(N
);
1234 -- We compute this if a component clause was present, otherwise we leave
1235 -- the computation up to the back end, since we don't know what layout
1238 -- Note that the attribute can apply to a naked record component
1239 -- in generated code (i.e. the prefix is an identifier that
1240 -- references the component or discriminant entity).
1242 when Attribute_Bit_Position
=> Bit_Position
: declare
1246 if Nkind
(Pref
) = N_Identifier
then
1247 CE
:= Entity
(Pref
);
1249 CE
:= Entity
(Selector_Name
(Pref
));
1252 if Known_Static_Component_Bit_Offset
(CE
) then
1254 Make_Integer_Literal
(Loc
,
1255 Intval
=> Component_Bit_Offset
(CE
)));
1256 Analyze_And_Resolve
(N
, Typ
);
1259 Apply_Universal_Integer_Attribute_Checks
(N
);
1267 -- A reference to P'Body_Version or P'Version is expanded to
1270 -- pragma Import (C, Vnn, "uuuuT");
1272 -- Get_Version_String (Vnn)
1274 -- where uuuu is the unit name (dots replaced by double underscore)
1275 -- and T is B for the cases of Body_Version, or Version applied to a
1276 -- subprogram acting as its own spec, and S for Version applied to a
1277 -- subprogram spec or package. This sequence of code references the
1278 -- the unsigned constant created in the main program by the binder.
1280 -- A special exception occurs for Standard, where the string returned
1281 -- is a copy of the library string in gnatvsn.ads.
1283 when Attribute_Body_Version | Attribute_Version
=> Version
: declare
1284 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1289 -- If not library unit, get to containing library unit
1291 Pent
:= Entity
(Pref
);
1292 while Pent
/= Standard_Standard
1293 and then Scope
(Pent
) /= Standard_Standard
1294 and then not Is_Child_Unit
(Pent
)
1296 Pent
:= Scope
(Pent
);
1299 -- Special case Standard and Standard.ASCII
1301 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
1303 Make_String_Literal
(Loc
,
1304 Strval
=> Verbose_Library_Version
));
1309 -- Build required string constant
1311 Get_Name_String
(Get_Unit_Name
(Pent
));
1314 for J
in 1 .. Name_Len
- 2 loop
1315 if Name_Buffer
(J
) = '.' then
1316 Store_String_Chars
("__");
1318 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
1322 -- Case of subprogram acting as its own spec, always use body
1324 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
1325 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
1327 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
1329 Store_String_Chars
("B");
1331 -- Case of no body present, always use spec
1333 elsif not Unit_Requires_Body
(Pent
) then
1334 Store_String_Chars
("S");
1336 -- Otherwise use B for Body_Version, S for spec
1338 elsif Id
= Attribute_Body_Version
then
1339 Store_String_Chars
("B");
1341 Store_String_Chars
("S");
1345 Lib
.Version_Referenced
(S
);
1347 -- Insert the object declaration
1349 Insert_Actions
(N
, New_List
(
1350 Make_Object_Declaration
(Loc
,
1351 Defining_Identifier
=> E
,
1352 Object_Definition
=>
1353 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
1355 -- Set entity as imported with correct external name
1357 Set_Is_Imported
(E
);
1358 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
1360 -- Set entity as internal to ensure proper Sprint output of its
1361 -- implicit importation.
1363 Set_Is_Internal
(E
);
1365 -- And now rewrite original reference
1368 Make_Function_Call
(Loc
,
1369 Name
=> New_Reference_To
(RTE
(RE_Get_Version_String
), Loc
),
1370 Parameter_Associations
=> New_List
(
1371 New_Occurrence_Of
(E
, Loc
))));
1374 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
1381 -- Transforms 'Ceiling into a call to the floating-point attribute
1382 -- function Ceiling in Fat_xxx (where xxx is the root type)
1384 when Attribute_Ceiling
=>
1385 Expand_Fpt_Attribute_R
(N
);
1391 -- Transforms 'Callable attribute into a call to the Callable function
1393 when Attribute_Callable
=> Callable
:
1395 -- We have an object of a task interface class-wide type as a prefix
1396 -- to Callable. Generate:
1397 -- callable (Task_Id (Pref._disp_get_task_id));
1399 if Ada_Version
>= Ada_2005
1400 and then Ekind
(Ptyp
) = E_Class_Wide_Type
1401 and then Is_Interface
(Ptyp
)
1402 and then Is_Task_Interface
(Ptyp
)
1405 Make_Function_Call
(Loc
,
1407 New_Reference_To
(RTE
(RE_Callable
), Loc
),
1408 Parameter_Associations
=> New_List
(
1409 Make_Unchecked_Type_Conversion
(Loc
,
1411 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
1413 Make_Selected_Component
(Loc
,
1415 New_Copy_Tree
(Pref
),
1417 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
1421 Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
1424 Analyze_And_Resolve
(N
, Standard_Boolean
);
1431 -- Transforms 'Caller attribute into a call to either the
1432 -- Task_Entry_Caller or the Protected_Entry_Caller function.
1434 when Attribute_Caller
=> Caller
: declare
1435 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
1436 Ent
: constant Entity_Id
:= Entity
(Pref
);
1437 Conctype
: constant Entity_Id
:= Scope
(Ent
);
1438 Nest_Depth
: Integer := 0;
1445 if Is_Protected_Type
(Conctype
) then
1446 case Corresponding_Runtime_Package
(Conctype
) is
1447 when System_Tasking_Protected_Objects_Entries
=>
1450 (RTE
(RE_Protected_Entry_Caller
), Loc
);
1452 when System_Tasking_Protected_Objects_Single_Entry
=>
1455 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
1458 raise Program_Error
;
1462 Unchecked_Convert_To
(Id_Kind
,
1463 Make_Function_Call
(Loc
,
1465 Parameter_Associations
=> New_List
(
1467 (Find_Protection_Object
(Current_Scope
), Loc
)))));
1472 -- Determine the nesting depth of the E'Caller attribute, that
1473 -- is, how many accept statements are nested within the accept
1474 -- statement for E at the point of E'Caller. The runtime uses
1475 -- this depth to find the specified entry call.
1477 for J
in reverse 0 .. Scope_Stack
.Last
loop
1478 S
:= Scope_Stack
.Table
(J
).Entity
;
1480 -- We should not reach the scope of the entry, as it should
1481 -- already have been checked in Sem_Attr that this attribute
1482 -- reference is within a matching accept statement.
1484 pragma Assert
(S
/= Conctype
);
1489 elsif Is_Entry
(S
) then
1490 Nest_Depth
:= Nest_Depth
+ 1;
1495 Unchecked_Convert_To
(Id_Kind
,
1496 Make_Function_Call
(Loc
,
1498 New_Reference_To
(RTE
(RE_Task_Entry_Caller
), Loc
),
1499 Parameter_Associations
=> New_List
(
1500 Make_Integer_Literal
(Loc
,
1501 Intval
=> Int
(Nest_Depth
))))));
1504 Analyze_And_Resolve
(N
, Id_Kind
);
1511 -- Transforms 'Compose into a call to the floating-point attribute
1512 -- function Compose in Fat_xxx (where xxx is the root type)
1514 -- Note: we strictly should have special code here to deal with the
1515 -- case of absurdly negative arguments (less than Integer'First)
1516 -- which will return a (signed) zero value, but it hardly seems
1517 -- worth the effort. Absurdly large positive arguments will raise
1518 -- constraint error which is fine.
1520 when Attribute_Compose
=>
1521 Expand_Fpt_Attribute_RI
(N
);
1527 when Attribute_Constrained
=> Constrained
: declare
1528 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
1530 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean;
1531 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1532 -- view of an aliased object whose subtype is constrained.
1534 ---------------------------------
1535 -- Is_Constrained_Aliased_View --
1536 ---------------------------------
1538 function Is_Constrained_Aliased_View
(Obj
: Node_Id
) return Boolean is
1542 if Is_Entity_Name
(Obj
) then
1545 if Present
(Renamed_Object
(E
)) then
1546 return Is_Constrained_Aliased_View
(Renamed_Object
(E
));
1548 return Is_Aliased
(E
) and then Is_Constrained
(Etype
(E
));
1552 return Is_Aliased_View
(Obj
)
1554 (Is_Constrained
(Etype
(Obj
))
1555 or else (Nkind
(Obj
) = N_Explicit_Dereference
1557 not Has_Constrained_Partial_View
1558 (Base_Type
(Etype
(Obj
)))));
1560 end Is_Constrained_Aliased_View
;
1562 -- Start of processing for Constrained
1565 -- Reference to a parameter where the value is passed as an extra
1566 -- actual, corresponding to the extra formal referenced by the
1567 -- Extra_Constrained field of the corresponding formal. If this
1568 -- is an entry in-parameter, it is replaced by a constant renaming
1569 -- for which Extra_Constrained is never created.
1571 if Present
(Formal_Ent
)
1572 and then Ekind
(Formal_Ent
) /= E_Constant
1573 and then Present
(Extra_Constrained
(Formal_Ent
))
1577 (Extra_Constrained
(Formal_Ent
), Sloc
(N
)));
1579 -- For variables with a Extra_Constrained field, we use the
1580 -- corresponding entity.
1582 elsif Nkind
(Pref
) = N_Identifier
1583 and then Ekind
(Entity
(Pref
)) = E_Variable
1584 and then Present
(Extra_Constrained
(Entity
(Pref
)))
1588 (Extra_Constrained
(Entity
(Pref
)), Sloc
(N
)));
1590 -- For all other entity names, we can tell at compile time
1592 elsif Is_Entity_Name
(Pref
) then
1594 Ent
: constant Entity_Id
:= Entity
(Pref
);
1598 -- (RM J.4) obsolescent cases
1600 if Is_Type
(Ent
) then
1604 if Is_Private_Type
(Ent
) then
1605 Res
:= not Has_Discriminants
(Ent
)
1606 or else Is_Constrained
(Ent
);
1608 -- It not a private type, must be a generic actual type
1609 -- that corresponded to a private type. We know that this
1610 -- correspondence holds, since otherwise the reference
1611 -- within the generic template would have been illegal.
1614 if Is_Composite_Type
(Underlying_Type
(Ent
)) then
1615 Res
:= Is_Constrained
(Ent
);
1621 -- If the prefix is not a variable or is aliased, then
1622 -- definitely true; if it's a formal parameter without an
1623 -- associated extra formal, then treat it as constrained.
1625 -- Ada 2005 (AI-363): An aliased prefix must be known to be
1626 -- constrained in order to set the attribute to True.
1628 elsif not Is_Variable
(Pref
)
1629 or else Present
(Formal_Ent
)
1630 or else (Ada_Version
< Ada_2005
1631 and then Is_Aliased_View
(Pref
))
1632 or else (Ada_Version
>= Ada_2005
1633 and then Is_Constrained_Aliased_View
(Pref
))
1637 -- Variable case, look at type to see if it is constrained.
1638 -- Note that the one case where this is not accurate (the
1639 -- procedure formal case), has been handled above.
1641 -- We use the Underlying_Type here (and below) in case the
1642 -- type is private without discriminants, but the full type
1643 -- has discriminants. This case is illegal, but we generate it
1644 -- internally for passing to the Extra_Constrained parameter.
1647 Res
:= Is_Constrained
(Underlying_Type
(Etype
(Ent
)));
1651 New_Reference_To
(Boolean_Literals
(Res
), Loc
));
1654 -- Prefix is not an entity name. These are also cases where we can
1655 -- always tell at compile time by looking at the form and type of the
1656 -- prefix. If an explicit dereference of an object with constrained
1657 -- partial view, this is unconstrained (Ada 2005 AI-363).
1663 not Is_Variable
(Pref
)
1665 (Nkind
(Pref
) = N_Explicit_Dereference
1667 not Has_Constrained_Partial_View
(Base_Type
(Ptyp
)))
1668 or else Is_Constrained
(Underlying_Type
(Ptyp
))),
1672 Analyze_And_Resolve
(N
, Standard_Boolean
);
1679 -- Transforms 'Copy_Sign into a call to the floating-point attribute
1680 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
1682 when Attribute_Copy_Sign
=>
1683 Expand_Fpt_Attribute_RR
(N
);
1689 -- Transforms 'Count attribute into a call to the Count function
1691 when Attribute_Count
=> Count
: declare
1693 Conctyp
: Entity_Id
;
1695 Entry_Id
: Entity_Id
;
1700 -- If the prefix is a member of an entry family, retrieve both
1701 -- entry name and index. For a simple entry there is no index.
1703 if Nkind
(Pref
) = N_Indexed_Component
then
1704 Entnam
:= Prefix
(Pref
);
1705 Index
:= First
(Expressions
(Pref
));
1711 Entry_Id
:= Entity
(Entnam
);
1713 -- Find the concurrent type in which this attribute is referenced
1714 -- (there had better be one).
1716 Conctyp
:= Current_Scope
;
1717 while not Is_Concurrent_Type
(Conctyp
) loop
1718 Conctyp
:= Scope
(Conctyp
);
1723 if Is_Protected_Type
(Conctyp
) then
1724 case Corresponding_Runtime_Package
(Conctyp
) is
1725 when System_Tasking_Protected_Objects_Entries
=>
1726 Name
:= New_Reference_To
(RTE
(RE_Protected_Count
), Loc
);
1729 Make_Function_Call
(Loc
,
1731 Parameter_Associations
=> New_List
(
1733 (Find_Protection_Object
(Current_Scope
), Loc
),
1734 Entry_Index_Expression
1735 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
1737 when System_Tasking_Protected_Objects_Single_Entry
=>
1739 New_Reference_To
(RTE
(RE_Protected_Count_Entry
), Loc
);
1742 Make_Function_Call
(Loc
,
1744 Parameter_Associations
=> New_List
(
1746 (Find_Protection_Object
(Current_Scope
), Loc
)));
1749 raise Program_Error
;
1756 Make_Function_Call
(Loc
,
1757 Name
=> New_Reference_To
(RTE
(RE_Task_Count
), Loc
),
1758 Parameter_Associations
=> New_List
(
1759 Entry_Index_Expression
(Loc
,
1760 Entry_Id
, Index
, Scope
(Entry_Id
))));
1763 -- The call returns type Natural but the context is universal integer
1764 -- so any integer type is allowed. The attribute was already resolved
1765 -- so its Etype is the required result type. If the base type of the
1766 -- context type is other than Standard.Integer we put in a conversion
1767 -- to the required type. This can be a normal typed conversion since
1768 -- both input and output types of the conversion are integer types
1770 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
1771 Rewrite
(N
, Convert_To
(Typ
, Call
));
1776 Analyze_And_Resolve
(N
, Typ
);
1783 -- This processing is shared by Elab_Spec
1785 -- What we do is to insert the following declarations
1788 -- pragma Import (C, enn, "name___elabb/s");
1790 -- and then the Elab_Body/Spec attribute is replaced by a reference
1791 -- to this defining identifier.
1793 when Attribute_Elab_Body |
1794 Attribute_Elab_Spec
=>
1797 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
1801 procedure Make_Elab_String
(Nod
: Node_Id
);
1802 -- Given Nod, an identifier, or a selected component, put the
1803 -- image into the current string literal, with double underline
1804 -- between components.
1806 ----------------------
1807 -- Make_Elab_String --
1808 ----------------------
1810 procedure Make_Elab_String
(Nod
: Node_Id
) is
1812 if Nkind
(Nod
) = N_Selected_Component
then
1813 Make_Elab_String
(Prefix
(Nod
));
1817 Store_String_Char
('$');
1819 Store_String_Char
('.');
1821 Store_String_Char
('_');
1822 Store_String_Char
('_');
1825 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
1828 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
1829 Get_Name_String
(Chars
(Nod
));
1832 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
1833 end Make_Elab_String
;
1835 -- Start of processing for Elab_Body/Elab_Spec
1838 -- First we need to prepare the string literal for the name of
1839 -- the elaboration routine to be referenced.
1842 Make_Elab_String
(Pref
);
1844 if VM_Target
= No_VM
then
1845 Store_String_Chars
("___elab");
1846 Lang
:= Make_Identifier
(Loc
, Name_C
);
1848 Store_String_Chars
("._elab");
1849 Lang
:= Make_Identifier
(Loc
, Name_Ada
);
1852 if Id
= Attribute_Elab_Body
then
1853 Store_String_Char
('b');
1855 Store_String_Char
('s');
1860 Insert_Actions
(N
, New_List
(
1861 Make_Subprogram_Declaration
(Loc
,
1863 Make_Procedure_Specification
(Loc
,
1864 Defining_Unit_Name
=> Ent
)),
1867 Chars
=> Name_Import
,
1868 Pragma_Argument_Associations
=> New_List
(
1869 Make_Pragma_Argument_Association
(Loc
,
1870 Expression
=> Lang
),
1872 Make_Pragma_Argument_Association
(Loc
,
1874 Make_Identifier
(Loc
, Chars
(Ent
))),
1876 Make_Pragma_Argument_Association
(Loc
,
1878 Make_String_Literal
(Loc
, Str
))))));
1880 Set_Entity
(N
, Ent
);
1881 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
1888 -- Elaborated is always True for preelaborated units, predefined units,
1889 -- pure units and units which have Elaborate_Body pragmas. These units
1890 -- have no elaboration entity.
1892 -- Note: The Elaborated attribute is never passed to the back end
1894 when Attribute_Elaborated
=> Elaborated
: declare
1895 Ent
: constant Entity_Id
:= Entity
(Pref
);
1898 if Present
(Elaboration_Entity
(Ent
)) then
1900 New_Occurrence_Of
(Elaboration_Entity
(Ent
), Loc
));
1902 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
1910 when Attribute_Enum_Rep
=> Enum_Rep
:
1912 -- X'Enum_Rep (Y) expands to
1916 -- This is simply a direct conversion from the enumeration type to
1917 -- the target integer type, which is treated by the back end as a
1918 -- normal integer conversion, treating the enumeration type as an
1919 -- integer, which is exactly what we want! We set Conversion_OK to
1920 -- make sure that the analyzer does not complain about what otherwise
1921 -- might be an illegal conversion.
1923 if Is_Non_Empty_List
(Exprs
) then
1925 OK_Convert_To
(Typ
, Relocate_Node
(First
(Exprs
))));
1927 -- X'Enum_Rep where X is an enumeration literal is replaced by
1928 -- the literal value.
1930 elsif Ekind
(Entity
(Pref
)) = E_Enumeration_Literal
then
1932 Make_Integer_Literal
(Loc
, Enumeration_Rep
(Entity
(Pref
))));
1934 -- If this is a renaming of a literal, recover the representation
1937 elsif Ekind
(Entity
(Pref
)) = E_Constant
1938 and then Present
(Renamed_Object
(Entity
(Pref
)))
1940 Ekind
(Entity
(Renamed_Object
(Entity
(Pref
))))
1941 = E_Enumeration_Literal
1944 Make_Integer_Literal
(Loc
,
1945 Enumeration_Rep
(Entity
(Renamed_Object
(Entity
(Pref
))))));
1947 -- X'Enum_Rep where X is an object does a direct unchecked conversion
1948 -- of the object value, as described for the type case above.
1952 OK_Convert_To
(Typ
, Relocate_Node
(Pref
)));
1956 Analyze_And_Resolve
(N
, Typ
);
1963 when Attribute_Enum_Val
=> Enum_Val
: declare
1965 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
1968 -- X'Enum_Val (Y) expands to
1970 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
1973 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
1976 Make_Raise_Constraint_Error
(Loc
,
1980 Make_Function_Call
(Loc
,
1982 New_Reference_To
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
1983 Parameter_Associations
=> New_List
(
1984 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
1985 New_Occurrence_Of
(Standard_False
, Loc
))),
1987 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
1988 Reason
=> CE_Range_Check_Failed
));
1991 Analyze_And_Resolve
(N
, Ptyp
);
1998 -- Transforms 'Exponent into a call to the floating-point attribute
1999 -- function Exponent in Fat_xxx (where xxx is the root type)
2001 when Attribute_Exponent
=>
2002 Expand_Fpt_Attribute_R
(N
);
2008 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2010 when Attribute_External_Tag
=> External_Tag
:
2013 Make_Function_Call
(Loc
,
2014 Name
=> New_Reference_To
(RTE
(RE_External_Tag
), Loc
),
2015 Parameter_Associations
=> New_List
(
2016 Make_Attribute_Reference
(Loc
,
2017 Attribute_Name
=> Name_Tag
,
2018 Prefix
=> Prefix
(N
)))));
2020 Analyze_And_Resolve
(N
, Standard_String
);
2027 when Attribute_First
=>
2029 -- If the prefix type is a constrained packed array type which
2030 -- already has a Packed_Array_Type representation defined, then
2031 -- replace this attribute with a direct reference to 'First of the
2032 -- appropriate index subtype (since otherwise the back end will try
2033 -- to give us the value of 'First for this implementation type).
2035 if Is_Constrained_Packed_Array
(Ptyp
) then
2037 Make_Attribute_Reference
(Loc
,
2038 Attribute_Name
=> Name_First
,
2039 Prefix
=> New_Reference_To
(Get_Index_Subtype
(N
), Loc
)));
2040 Analyze_And_Resolve
(N
, Typ
);
2042 elsif Is_Access_Type
(Ptyp
) then
2043 Apply_Access_Check
(N
);
2050 -- Compute this if component clause was present, otherwise we leave the
2051 -- computation to be completed in the back-end, since we don't know what
2052 -- layout will be chosen.
2054 when Attribute_First_Bit
=> First_Bit
: declare
2055 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
2058 if Known_Static_Component_Bit_Offset
(CE
) then
2060 Make_Integer_Literal
(Loc
,
2061 Component_Bit_Offset
(CE
) mod System_Storage_Unit
));
2063 Analyze_And_Resolve
(N
, Typ
);
2066 Apply_Universal_Integer_Attribute_Checks
(N
);
2076 -- fixtype'Fixed_Value (integer-value)
2080 -- fixtype(integer-value)
2082 -- We do all the required analysis of the conversion here, because we do
2083 -- not want this to go through the fixed-point conversion circuits. Note
2084 -- that the back end always treats fixed-point as equivalent to the
2085 -- corresponding integer type anyway.
2087 when Attribute_Fixed_Value
=> Fixed_Value
:
2090 Make_Type_Conversion
(Loc
,
2091 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
2092 Expression
=> Relocate_Node
(First
(Exprs
))));
2093 Set_Etype
(N
, Entity
(Pref
));
2096 -- Note: it might appear that a properly analyzed unchecked conversion
2097 -- would be just fine here, but that's not the case, since the full
2098 -- range checks performed by the following call are critical!
2100 Apply_Type_Conversion_Checks
(N
);
2107 -- Transforms 'Floor into a call to the floating-point attribute
2108 -- function Floor in Fat_xxx (where xxx is the root type)
2110 when Attribute_Floor
=>
2111 Expand_Fpt_Attribute_R
(N
);
2117 -- For the fixed-point type Typ:
2123 -- Result_Type (System.Fore (Universal_Real (Type'First)),
2124 -- Universal_Real (Type'Last))
2126 -- Note that we know that the type is a non-static subtype, or Fore
2127 -- would have itself been computed dynamically in Eval_Attribute.
2129 when Attribute_Fore
=> Fore
: begin
2132 Make_Function_Call
(Loc
,
2133 Name
=> New_Reference_To
(RTE
(RE_Fore
), Loc
),
2135 Parameter_Associations
=> New_List
(
2136 Convert_To
(Universal_Real
,
2137 Make_Attribute_Reference
(Loc
,
2138 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2139 Attribute_Name
=> Name_First
)),
2141 Convert_To
(Universal_Real
,
2142 Make_Attribute_Reference
(Loc
,
2143 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2144 Attribute_Name
=> Name_Last
))))));
2146 Analyze_And_Resolve
(N
, Typ
);
2153 -- Transforms 'Fraction into a call to the floating-point attribute
2154 -- function Fraction in Fat_xxx (where xxx is the root type)
2156 when Attribute_Fraction
=>
2157 Expand_Fpt_Attribute_R
(N
);
2163 when Attribute_From_Any
=> From_Any
: declare
2164 P_Type
: constant Entity_Id
:= Etype
(Pref
);
2165 Decls
: constant List_Id
:= New_List
;
2168 Build_From_Any_Call
(P_Type
,
2169 Relocate_Node
(First
(Exprs
)),
2171 Insert_Actions
(N
, Decls
);
2172 Analyze_And_Resolve
(N
, P_Type
);
2179 -- For an exception returns a reference to the exception data:
2180 -- Exception_Id!(Prefix'Reference)
2182 -- For a task it returns a reference to the _task_id component of
2183 -- corresponding record:
2185 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2187 -- in Ada.Task_Identification
2189 when Attribute_Identity
=> Identity
: declare
2190 Id_Kind
: Entity_Id
;
2193 if Ptyp
= Standard_Exception_Type
then
2194 Id_Kind
:= RTE
(RE_Exception_Id
);
2196 if Present
(Renamed_Object
(Entity
(Pref
))) then
2197 Set_Entity
(Pref
, Renamed_Object
(Entity
(Pref
)));
2201 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
2203 Id_Kind
:= RTE
(RO_AT_Task_Id
);
2205 -- If the prefix is a task interface, the Task_Id is obtained
2206 -- dynamically through a dispatching call, as for other task
2207 -- attributes applied to interfaces.
2209 if Ada_Version
>= Ada_2005
2210 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2211 and then Is_Interface
(Ptyp
)
2212 and then Is_Task_Interface
(Ptyp
)
2215 Unchecked_Convert_To
(Id_Kind
,
2216 Make_Selected_Component
(Loc
,
2218 New_Copy_Tree
(Pref
),
2220 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))));
2224 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
2228 Analyze_And_Resolve
(N
, Id_Kind
);
2235 -- Image attribute is handled in separate unit Exp_Imgv
2237 when Attribute_Image
=>
2238 Exp_Imgv
.Expand_Image_Attribute
(N
);
2244 -- X'Img is expanded to typ'Image (X), where typ is the type of X
2246 when Attribute_Img
=> Img
:
2249 Make_Attribute_Reference
(Loc
,
2250 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
2251 Attribute_Name
=> Name_Image
,
2252 Expressions
=> New_List
(Relocate_Node
(Pref
))));
2254 Analyze_And_Resolve
(N
, Standard_String
);
2261 when Attribute_Input
=> Input
: declare
2262 P_Type
: constant Entity_Id
:= Entity
(Pref
);
2263 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
2264 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
2265 Strm
: constant Node_Id
:= First
(Exprs
);
2273 Cntrl
: Node_Id
:= Empty
;
2274 -- Value for controlling argument in call. Always Empty except in
2275 -- the dispatching (class-wide type) case, where it is a reference
2276 -- to the dummy object initialized to the right internal tag.
2278 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
2279 -- The expansion of the attribute reference may generate a call to
2280 -- a user-defined stream subprogram that is frozen by the call. This
2281 -- can lead to access-before-elaboration problem if the reference
2282 -- appears in an object declaration and the subprogram body has not
2283 -- been seen. The freezing of the subprogram requires special code
2284 -- because it appears in an expanded context where expressions do
2285 -- not freeze their constituents.
2287 ------------------------------
2288 -- Freeze_Stream_Subprogram --
2289 ------------------------------
2291 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
2292 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
2296 -- If this is user-defined subprogram, the corresponding
2297 -- stream function appears as a renaming-as-body, and the
2298 -- user subprogram must be retrieved by tree traversal.
2301 and then Nkind
(Decl
) = N_Subprogram_Declaration
2302 and then Present
(Corresponding_Body
(Decl
))
2304 Bod
:= Corresponding_Body
(Decl
);
2306 if Nkind
(Unit_Declaration_Node
(Bod
)) =
2307 N_Subprogram_Renaming_Declaration
2309 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
2312 end Freeze_Stream_Subprogram
;
2314 -- Start of processing for Input
2317 -- If no underlying type, we have an error that will be diagnosed
2318 -- elsewhere, so here we just completely ignore the expansion.
2324 -- If there is a TSS for Input, just call it
2326 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
);
2328 if Present
(Fname
) then
2332 -- If there is a Stream_Convert pragma, use it, we rewrite
2334 -- sourcetyp'Input (stream)
2338 -- sourcetyp (streamread (strmtyp'Input (stream)));
2340 -- where streamread is the given Read function that converts an
2341 -- argument of type strmtyp to type sourcetyp or a type from which
2342 -- it is derived (extra conversion required for the derived case).
2344 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
2346 if Present
(Prag
) then
2347 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
2348 Rfunc
:= Entity
(Expression
(Arg2
));
2352 Make_Function_Call
(Loc
,
2353 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
2354 Parameter_Associations
=> New_List
(
2355 Make_Attribute_Reference
(Loc
,
2358 (Etype
(First_Formal
(Rfunc
)), Loc
),
2359 Attribute_Name
=> Name_Input
,
2360 Expressions
=> Exprs
)))));
2362 Analyze_And_Resolve
(N
, B_Type
);
2367 elsif Is_Elementary_Type
(U_Type
) then
2369 -- A special case arises if we have a defined _Read routine,
2370 -- since in this case we are required to call this routine.
2372 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Read
)) then
2373 Build_Record_Or_Elementary_Input_Function
2374 (Loc
, U_Type
, Decl
, Fname
);
2375 Insert_Action
(N
, Decl
);
2377 -- For normal cases, we call the I_xxx routine directly
2380 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
2381 Analyze_And_Resolve
(N
, P_Type
);
2387 elsif Is_Array_Type
(U_Type
) then
2388 Build_Array_Input_Function
(Loc
, U_Type
, Decl
, Fname
);
2389 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
2391 -- Dispatching case with class-wide type
2393 elsif Is_Class_Wide_Type
(P_Type
) then
2395 -- No need to do anything else compiling under restriction
2396 -- No_Dispatching_Calls. During the semantic analysis we
2397 -- already notified such violation.
2399 if Restriction_Active
(No_Dispatching_Calls
) then
2404 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
2410 -- Read the internal tag (RM 13.13.2(34)) and use it to
2411 -- initialize a dummy tag object:
2413 -- Dnn : Ada.Tags.Tag :=
2414 -- Descendant_Tag (String'Input (Strm), P_Type);
2416 -- This dummy object is used only to provide a controlling
2417 -- argument for the eventual _Input call. Descendant_Tag is
2418 -- called rather than Internal_Tag to ensure that we have a
2419 -- tag for a type that is descended from the prefix type and
2420 -- declared at the same accessibility level (the exception
2421 -- Tag_Error will be raised otherwise). The level check is
2422 -- required for Ada 2005 because tagged types can be
2423 -- extended in nested scopes (AI-344).
2426 Make_Function_Call
(Loc
,
2428 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
2429 Parameter_Associations
=> New_List
(
2430 Make_Attribute_Reference
(Loc
,
2431 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
2432 Attribute_Name
=> Name_Input
,
2433 Expressions
=> New_List
(
2434 Relocate_Node
(Duplicate_Subexpr
(Strm
)))),
2435 Make_Attribute_Reference
(Loc
,
2436 Prefix
=> New_Reference_To
(P_Type
, Loc
),
2437 Attribute_Name
=> Name_Tag
)));
2439 Dnn
:= Make_Temporary
(Loc
, 'D', Expr
);
2442 Make_Object_Declaration
(Loc
,
2443 Defining_Identifier
=> Dnn
,
2444 Object_Definition
=>
2445 New_Occurrence_Of
(RTE
(RE_Tag
), Loc
),
2446 Expression
=> Expr
);
2448 Insert_Action
(N
, Decl
);
2450 -- Now we need to get the entity for the call, and construct
2451 -- a function call node, where we preset a reference to Dnn
2452 -- as the controlling argument (doing an unchecked convert
2453 -- to the class-wide tagged type to make it look like a real
2456 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
2458 Unchecked_Convert_To
(P_Type
,
2459 New_Occurrence_Of
(Dnn
, Loc
));
2460 Set_Etype
(Cntrl
, P_Type
);
2461 Set_Parent
(Cntrl
, N
);
2464 -- For tagged types, use the primitive Input function
2466 elsif Is_Tagged_Type
(U_Type
) then
2467 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
2469 -- All other record type cases, including protected records. The
2470 -- latter only arise for expander generated code for handling
2471 -- shared passive partition access.
2475 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
2477 -- Ada 2005 (AI-216): Program_Error is raised executing default
2478 -- implementation of the Input attribute of an unchecked union
2479 -- type if the type lacks default discriminant values.
2481 if Is_Unchecked_Union
(Base_Type
(U_Type
))
2482 and then No
(Discriminant_Constraint
(U_Type
))
2485 Make_Raise_Program_Error
(Loc
,
2486 Reason
=> PE_Unchecked_Union_Restriction
));
2491 Build_Record_Or_Elementary_Input_Function
2492 (Loc
, Base_Type
(U_Type
), Decl
, Fname
);
2493 Insert_Action
(N
, Decl
);
2495 if Nkind
(Parent
(N
)) = N_Object_Declaration
2496 and then Is_Record_Type
(U_Type
)
2498 -- The stream function may contain calls to user-defined
2499 -- Read procedures for individual components.
2506 Comp
:= First_Component
(U_Type
);
2507 while Present
(Comp
) loop
2509 Find_Stream_Subprogram
2510 (Etype
(Comp
), TSS_Stream_Read
);
2512 if Present
(Func
) then
2513 Freeze_Stream_Subprogram
(Func
);
2516 Next_Component
(Comp
);
2523 -- If we fall through, Fname is the function to be called. The result
2524 -- is obtained by calling the appropriate function, then converting
2525 -- the result. The conversion does a subtype check.
2528 Make_Function_Call
(Loc
,
2529 Name
=> New_Occurrence_Of
(Fname
, Loc
),
2530 Parameter_Associations
=> New_List
(
2531 Relocate_Node
(Strm
)));
2533 Set_Controlling_Argument
(Call
, Cntrl
);
2534 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
2535 Analyze_And_Resolve
(N
, P_Type
);
2537 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
2538 Freeze_Stream_Subprogram
(Fname
);
2548 -- inttype'Fixed_Value (fixed-value)
2552 -- inttype(integer-value))
2554 -- we do all the required analysis of the conversion here, because we do
2555 -- not want this to go through the fixed-point conversion circuits. Note
2556 -- that the back end always treats fixed-point as equivalent to the
2557 -- corresponding integer type anyway.
2559 when Attribute_Integer_Value
=> Integer_Value
:
2562 Make_Type_Conversion
(Loc
,
2563 Subtype_Mark
=> New_Occurrence_Of
(Entity
(Pref
), Loc
),
2564 Expression
=> Relocate_Node
(First
(Exprs
))));
2565 Set_Etype
(N
, Entity
(Pref
));
2568 -- Note: it might appear that a properly analyzed unchecked conversion
2569 -- would be just fine here, but that's not the case, since the full
2570 -- range checks performed by the following call are critical!
2572 Apply_Type_Conversion_Checks
(N
);
2579 when Attribute_Invalid_Value
=>
2580 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
2586 when Attribute_Last
=>
2588 -- If the prefix type is a constrained packed array type which
2589 -- already has a Packed_Array_Type representation defined, then
2590 -- replace this attribute with a direct reference to 'Last of the
2591 -- appropriate index subtype (since otherwise the back end will try
2592 -- to give us the value of 'Last for this implementation type).
2594 if Is_Constrained_Packed_Array
(Ptyp
) then
2596 Make_Attribute_Reference
(Loc
,
2597 Attribute_Name
=> Name_Last
,
2598 Prefix
=> New_Reference_To
(Get_Index_Subtype
(N
), Loc
)));
2599 Analyze_And_Resolve
(N
, Typ
);
2601 elsif Is_Access_Type
(Ptyp
) then
2602 Apply_Access_Check
(N
);
2609 -- We compute this if a component clause was present, otherwise we leave
2610 -- the computation up to the back end, since we don't know what layout
2613 when Attribute_Last_Bit
=> Last_Bit
: declare
2614 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
2617 if Known_Static_Component_Bit_Offset
(CE
)
2618 and then Known_Static_Esize
(CE
)
2621 Make_Integer_Literal
(Loc
,
2622 Intval
=> (Component_Bit_Offset
(CE
) mod System_Storage_Unit
)
2625 Analyze_And_Resolve
(N
, Typ
);
2628 Apply_Universal_Integer_Attribute_Checks
(N
);
2636 -- Transforms 'Leading_Part into a call to the floating-point attribute
2637 -- function Leading_Part in Fat_xxx (where xxx is the root type)
2639 -- Note: strictly, we should generate special case code to deal with
2640 -- absurdly large positive arguments (greater than Integer'Last), which
2641 -- result in returning the first argument unchanged, but it hardly seems
2642 -- worth the effort. We raise constraint error for absurdly negative
2643 -- arguments which is fine.
2645 when Attribute_Leading_Part
=>
2646 Expand_Fpt_Attribute_RI
(N
);
2652 when Attribute_Length
=> declare
2657 -- Processing for packed array types
2659 if Is_Array_Type
(Ptyp
) and then Is_Packed
(Ptyp
) then
2660 Ityp
:= Get_Index_Subtype
(N
);
2662 -- If the index type, Ityp, is an enumeration type with holes,
2663 -- then we calculate X'Length explicitly using
2666 -- (0, Ityp'Pos (X'Last (N)) -
2667 -- Ityp'Pos (X'First (N)) + 1);
2669 -- Since the bounds in the template are the representation values
2670 -- and the back end would get the wrong value.
2672 if Is_Enumeration_Type
(Ityp
)
2673 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
2678 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
2682 Make_Attribute_Reference
(Loc
,
2683 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2684 Attribute_Name
=> Name_Max
,
2685 Expressions
=> New_List
2686 (Make_Integer_Literal
(Loc
, 0),
2690 Make_Op_Subtract
(Loc
,
2692 Make_Attribute_Reference
(Loc
,
2693 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2694 Attribute_Name
=> Name_Pos
,
2696 Expressions
=> New_List
(
2697 Make_Attribute_Reference
(Loc
,
2698 Prefix
=> Duplicate_Subexpr
(Pref
),
2699 Attribute_Name
=> Name_Last
,
2700 Expressions
=> New_List
(
2701 Make_Integer_Literal
(Loc
, Xnum
))))),
2704 Make_Attribute_Reference
(Loc
,
2705 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
2706 Attribute_Name
=> Name_Pos
,
2708 Expressions
=> New_List
(
2709 Make_Attribute_Reference
(Loc
,
2711 Duplicate_Subexpr_No_Checks
(Pref
),
2712 Attribute_Name
=> Name_First
,
2713 Expressions
=> New_List
(
2714 Make_Integer_Literal
(Loc
, Xnum
)))))),
2716 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
2718 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
2721 -- If the prefix type is a constrained packed array type which
2722 -- already has a Packed_Array_Type representation defined, then
2723 -- replace this attribute with a direct reference to 'Range_Length
2724 -- of the appropriate index subtype (since otherwise the back end
2725 -- will try to give us the value of 'Length for this
2726 -- implementation type).
2728 elsif Is_Constrained
(Ptyp
) then
2730 Make_Attribute_Reference
(Loc
,
2731 Attribute_Name
=> Name_Range_Length
,
2732 Prefix
=> New_Reference_To
(Ityp
, Loc
)));
2733 Analyze_And_Resolve
(N
, Typ
);
2738 elsif Is_Access_Type
(Ptyp
) then
2739 Apply_Access_Check
(N
);
2741 -- If the designated type is a packed array type, then we convert
2742 -- the reference to:
2745 -- xtyp'Pos (Pref'Last (Expr)) -
2746 -- xtyp'Pos (Pref'First (Expr)));
2748 -- This is a bit complex, but it is the easiest thing to do that
2749 -- works in all cases including enum types with holes xtyp here
2750 -- is the appropriate index type.
2753 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
2757 if Is_Array_Type
(Dtyp
) and then Is_Packed
(Dtyp
) then
2758 Xtyp
:= Get_Index_Subtype
(N
);
2761 Make_Attribute_Reference
(Loc
,
2762 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
2763 Attribute_Name
=> Name_Max
,
2764 Expressions
=> New_List
(
2765 Make_Integer_Literal
(Loc
, 0),
2768 Make_Integer_Literal
(Loc
, 1),
2769 Make_Op_Subtract
(Loc
,
2771 Make_Attribute_Reference
(Loc
,
2772 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
2773 Attribute_Name
=> Name_Pos
,
2774 Expressions
=> New_List
(
2775 Make_Attribute_Reference
(Loc
,
2776 Prefix
=> Duplicate_Subexpr
(Pref
),
2777 Attribute_Name
=> Name_Last
,
2779 New_Copy_List
(Exprs
)))),
2782 Make_Attribute_Reference
(Loc
,
2783 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
2784 Attribute_Name
=> Name_Pos
,
2785 Expressions
=> New_List
(
2786 Make_Attribute_Reference
(Loc
,
2788 Duplicate_Subexpr_No_Checks
(Pref
),
2789 Attribute_Name
=> Name_First
,
2791 New_Copy_List
(Exprs
)))))))));
2793 Analyze_And_Resolve
(N
, Typ
);
2797 -- Otherwise leave it to the back end
2800 Apply_Universal_Integer_Attribute_Checks
(N
);
2808 -- Transforms 'Machine into a call to the floating-point attribute
2809 -- function Machine in Fat_xxx (where xxx is the root type)
2811 when Attribute_Machine
=>
2812 Expand_Fpt_Attribute_R
(N
);
2814 ----------------------
2815 -- Machine_Rounding --
2816 ----------------------
2818 -- Transforms 'Machine_Rounding into a call to the floating-point
2819 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2820 -- type). Expansion is avoided for cases the back end can handle
2823 when Attribute_Machine_Rounding
=>
2824 if not Is_Inline_Floating_Point_Attribute
(N
) then
2825 Expand_Fpt_Attribute_R
(N
);
2832 -- Machine_Size is equivalent to Object_Size, so transform it into
2833 -- Object_Size and that way the back end never sees Machine_Size.
2835 when Attribute_Machine_Size
=>
2837 Make_Attribute_Reference
(Loc
,
2838 Prefix
=> Prefix
(N
),
2839 Attribute_Name
=> Name_Object_Size
));
2841 Analyze_And_Resolve
(N
, Typ
);
2847 -- The only case that can get this far is the dynamic case of the old
2848 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
2855 -- ityp (System.Mantissa.Mantissa_Value
2856 -- (Integer'Integer_Value (typ'First),
2857 -- Integer'Integer_Value (typ'Last)));
2859 when Attribute_Mantissa
=> Mantissa
: begin
2862 Make_Function_Call
(Loc
,
2863 Name
=> New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
2865 Parameter_Associations
=> New_List
(
2867 Make_Attribute_Reference
(Loc
,
2868 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
2869 Attribute_Name
=> Name_Integer_Value
,
2870 Expressions
=> New_List
(
2872 Make_Attribute_Reference
(Loc
,
2873 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2874 Attribute_Name
=> Name_First
))),
2876 Make_Attribute_Reference
(Loc
,
2877 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
2878 Attribute_Name
=> Name_Integer_Value
,
2879 Expressions
=> New_List
(
2881 Make_Attribute_Reference
(Loc
,
2882 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2883 Attribute_Name
=> Name_Last
)))))));
2885 Analyze_And_Resolve
(N
, Typ
);
2888 --------------------
2889 -- Mechanism_Code --
2890 --------------------
2892 when Attribute_Mechanism_Code
=>
2894 -- We must replace the prefix in the renamed case
2896 if Is_Entity_Name
(Pref
)
2897 and then Present
(Alias
(Entity
(Pref
)))
2899 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
2906 when Attribute_Mod
=> Mod_Case
: declare
2907 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
2908 Hi
: constant Node_Id
:= Type_High_Bound
(Etype
(Arg
));
2909 Modv
: constant Uint
:= Modulus
(Btyp
);
2913 -- This is not so simple. The issue is what type to use for the
2914 -- computation of the modular value.
2916 -- The easy case is when the modulus value is within the bounds
2917 -- of the signed integer type of the argument. In this case we can
2918 -- just do the computation in that signed integer type, and then
2919 -- do an ordinary conversion to the target type.
2921 if Modv
<= Expr_Value
(Hi
) then
2926 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
2928 -- Here we know that the modulus is larger than type'Last of the
2929 -- integer type. There are two cases to consider:
2931 -- a) The integer value is non-negative. In this case, it is
2932 -- returned as the result (since it is less than the modulus).
2934 -- b) The integer value is negative. In this case, we know that the
2935 -- result is modulus + value, where the value might be as small as
2936 -- -modulus. The trouble is what type do we use to do the subtract.
2937 -- No type will do, since modulus can be as big as 2**64, and no
2938 -- integer type accommodates this value. Let's do bit of algebra
2941 -- = modulus - (-value)
2942 -- = (modulus - 1) - (-value - 1)
2944 -- Now modulus - 1 is certainly in range of the modular type.
2945 -- -value is in the range 1 .. modulus, so -value -1 is in the
2946 -- range 0 .. modulus-1 which is in range of the modular type.
2947 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
2948 -- which we can compute using the integer base type.
2950 -- Once this is done we analyze the conditional expression without
2951 -- range checks, because we know everything is in range, and we
2952 -- want to prevent spurious warnings on either branch.
2956 Make_Conditional_Expression
(Loc
,
2957 Expressions
=> New_List
(
2959 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
2960 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
2963 Duplicate_Subexpr_No_Checks
(Arg
)),
2965 Make_Op_Subtract
(Loc
,
2967 Make_Integer_Literal
(Loc
,
2968 Intval
=> Modv
- 1),
2974 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
2976 Make_Integer_Literal
(Loc
,
2977 Intval
=> 1))))))));
2981 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
2988 -- Transforms 'Model into a call to the floating-point attribute
2989 -- function Model in Fat_xxx (where xxx is the root type)
2991 when Attribute_Model
=>
2992 Expand_Fpt_Attribute_R
(N
);
2998 -- The processing for Object_Size shares the processing for Size
3004 when Attribute_Old
=> Old
: declare
3005 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T', Pref
);
3010 -- Find the nearest subprogram body, ignoring _Preconditions
3014 Subp
:= Parent
(Subp
);
3015 exit when Nkind
(Subp
) = N_Subprogram_Body
3016 and then Chars
(Defining_Entity
(Subp
)) /= Name_uPostconditions
;
3019 -- Insert the initialized object declaration at the start of the
3020 -- subprogram's declarations.
3023 Make_Object_Declaration
(Loc
,
3024 Defining_Identifier
=> Tnn
,
3025 Constant_Present
=> True,
3026 Object_Definition
=> New_Occurrence_Of
(Etype
(N
), Loc
),
3027 Expression
=> Pref
);
3029 -- Push the subprogram's scope, so that the object will be analyzed
3030 -- in that context (rather than the context of the Precondition
3031 -- subprogram) and will have its Scope set properly.
3033 if Present
(Corresponding_Spec
(Subp
)) then
3034 Push_Scope
(Corresponding_Spec
(Subp
));
3036 Push_Scope
(Defining_Entity
(Subp
));
3039 if Is_Empty_List
(Declarations
(Subp
)) then
3040 Set_Declarations
(Subp
, New_List
(Asn_Stm
));
3043 Insert_Action
(First
(Declarations
(Subp
)), Asn_Stm
);
3048 Rewrite
(N
, New_Occurrence_Of
(Tnn
, Loc
));
3055 when Attribute_Output
=> Output
: declare
3056 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3057 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3065 -- If no underlying type, we have an error that will be diagnosed
3066 -- elsewhere, so here we just completely ignore the expansion.
3072 -- If TSS for Output is present, just call it
3074 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
);
3076 if Present
(Pname
) then
3080 -- If there is a Stream_Convert pragma, use it, we rewrite
3082 -- sourcetyp'Output (stream, Item)
3086 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3088 -- where strmwrite is the given Write function that converts an
3089 -- argument of type sourcetyp or a type acctyp, from which it is
3090 -- derived to type strmtyp. The conversion to acttyp is required
3091 -- for the derived case.
3093 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3095 if Present
(Prag
) then
3097 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
3098 Wfunc
:= Entity
(Expression
(Arg3
));
3101 Make_Attribute_Reference
(Loc
,
3102 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
3103 Attribute_Name
=> Name_Output
,
3104 Expressions
=> New_List
(
3105 Relocate_Node
(First
(Exprs
)),
3106 Make_Function_Call
(Loc
,
3107 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
3108 Parameter_Associations
=> New_List
(
3109 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
3110 Relocate_Node
(Next
(First
(Exprs
)))))))));
3115 -- For elementary types, we call the W_xxx routine directly.
3116 -- Note that the effect of Write and Output is identical for
3117 -- the case of an elementary type, since there are no
3118 -- discriminants or bounds.
3120 elsif Is_Elementary_Type
(U_Type
) then
3122 -- A special case arises if we have a defined _Write routine,
3123 -- since in this case we are required to call this routine.
3125 if Present
(TSS
(Base_Type
(U_Type
), TSS_Stream_Write
)) then
3126 Build_Record_Or_Elementary_Output_Procedure
3127 (Loc
, U_Type
, Decl
, Pname
);
3128 Insert_Action
(N
, Decl
);
3130 -- For normal cases, we call the W_xxx routine directly
3133 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
3140 elsif Is_Array_Type
(U_Type
) then
3141 Build_Array_Output_Procedure
(Loc
, U_Type
, Decl
, Pname
);
3142 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3144 -- Class-wide case, first output external tag, then dispatch
3145 -- to the appropriate primitive Output function (RM 13.13.2(31)).
3147 elsif Is_Class_Wide_Type
(P_Type
) then
3149 -- No need to do anything else compiling under restriction
3150 -- No_Dispatching_Calls. During the semantic analysis we
3151 -- already notified such violation.
3153 if Restriction_Active
(No_Dispatching_Calls
) then
3158 Strm
: constant Node_Id
:= First
(Exprs
);
3159 Item
: constant Node_Id
:= Next
(Strm
);
3162 -- Ada 2005 (AI-344): Check that the accessibility level
3163 -- of the type of the output object is not deeper than
3164 -- that of the attribute's prefix type.
3166 -- if Get_Access_Level (Item'Tag)
3167 -- /= Get_Access_Level (P_Type'Tag)
3172 -- String'Output (Strm, External_Tag (Item'Tag));
3174 -- We cannot figure out a practical way to implement this
3175 -- accessibility check on virtual machines, so we omit it.
3177 if Ada_Version
>= Ada_2005
3178 and then Tagged_Type_Expansion
3181 Make_Implicit_If_Statement
(N
,
3185 Build_Get_Access_Level
(Loc
,
3186 Make_Attribute_Reference
(Loc
,
3189 Duplicate_Subexpr
(Item
,
3191 Attribute_Name
=> Name_Tag
)),
3194 Make_Integer_Literal
(Loc
,
3195 Type_Access_Level
(P_Type
))),
3198 New_List
(Make_Raise_Statement
(Loc
,
3200 RTE
(RE_Tag_Error
), Loc
)))));
3204 Make_Attribute_Reference
(Loc
,
3205 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
3206 Attribute_Name
=> Name_Output
,
3207 Expressions
=> New_List
(
3208 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
3209 Make_Function_Call
(Loc
,
3211 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3212 Parameter_Associations
=> New_List
(
3213 Make_Attribute_Reference
(Loc
,
3216 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
3217 Attribute_Name
=> Name_Tag
))))));
3220 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
3222 -- Tagged type case, use the primitive Output function
3224 elsif Is_Tagged_Type
(U_Type
) then
3225 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
3227 -- All other record type cases, including protected records.
3228 -- The latter only arise for expander generated code for
3229 -- handling shared passive partition access.
3233 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3235 -- Ada 2005 (AI-216): Program_Error is raised when executing
3236 -- the default implementation of the Output attribute of an
3237 -- unchecked union type if the type lacks default discriminant
3240 if Is_Unchecked_Union
(Base_Type
(U_Type
))
3241 and then No
(Discriminant_Constraint
(U_Type
))
3244 Make_Raise_Program_Error
(Loc
,
3245 Reason
=> PE_Unchecked_Union_Restriction
));
3250 Build_Record_Or_Elementary_Output_Procedure
3251 (Loc
, Base_Type
(U_Type
), Decl
, Pname
);
3252 Insert_Action
(N
, Decl
);
3256 -- If we fall through, Pname is the name of the procedure to call
3258 Rewrite_Stream_Proc_Call
(Pname
);
3265 -- For enumeration types with a standard representation, Pos is
3266 -- handled by the back end.
3268 -- For enumeration types, with a non-standard representation we generate
3269 -- a call to the _Rep_To_Pos function created when the type was frozen.
3270 -- The call has the form
3272 -- _rep_to_pos (expr, flag)
3274 -- The parameter flag is True if range checks are enabled, causing
3275 -- Program_Error to be raised if the expression has an invalid
3276 -- representation, and False if range checks are suppressed.
3278 -- For integer types, Pos is equivalent to a simple integer
3279 -- conversion and we rewrite it as such
3281 when Attribute_Pos
=> Pos
:
3283 Etyp
: Entity_Id
:= Base_Type
(Entity
(Pref
));
3286 -- Deal with zero/non-zero boolean values
3288 if Is_Boolean_Type
(Etyp
) then
3289 Adjust_Condition
(First
(Exprs
));
3290 Etyp
:= Standard_Boolean
;
3291 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
3294 -- Case of enumeration type
3296 if Is_Enumeration_Type
(Etyp
) then
3298 -- Non-standard enumeration type (generate call)
3300 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
3301 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
3304 Make_Function_Call
(Loc
,
3306 New_Reference_To
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
3307 Parameter_Associations
=> Exprs
)));
3309 Analyze_And_Resolve
(N
, Typ
);
3311 -- Standard enumeration type (do universal integer check)
3314 Apply_Universal_Integer_Attribute_Checks
(N
);
3317 -- Deal with integer types (replace by conversion)
3319 elsif Is_Integer_Type
(Etyp
) then
3320 Rewrite
(N
, Convert_To
(Typ
, First
(Exprs
)));
3321 Analyze_And_Resolve
(N
, Typ
);
3330 -- We compute this if a component clause was present, otherwise we leave
3331 -- the computation up to the back end, since we don't know what layout
3334 when Attribute_Position
=> Position
:
3336 CE
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
3339 if Present
(Component_Clause
(CE
)) then
3341 Make_Integer_Literal
(Loc
,
3342 Intval
=> Component_Bit_Offset
(CE
) / System_Storage_Unit
));
3343 Analyze_And_Resolve
(N
, Typ
);
3346 Apply_Universal_Integer_Attribute_Checks
(N
);
3354 -- 1. Deal with enumeration types with holes
3355 -- 2. For floating-point, generate call to attribute function
3356 -- 3. For other cases, deal with constraint checking
3358 when Attribute_Pred
=> Pred
:
3360 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3364 -- For enumeration types with non-standard representations, we
3365 -- expand typ'Pred (x) into
3367 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
3369 -- If the representation is contiguous, we compute instead
3370 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3371 -- The conversion function Enum_Pos_To_Rep is defined on the
3372 -- base type, not the subtype, so we have to use the base type
3373 -- explicitly for this and other enumeration attributes.
3375 if Is_Enumeration_Type
(Ptyp
)
3376 and then Present
(Enum_Pos_To_Rep
(Etyp
))
3378 if Has_Contiguous_Rep
(Etyp
) then
3380 Unchecked_Convert_To
(Ptyp
,
3383 Make_Integer_Literal
(Loc
,
3384 Enumeration_Rep
(First_Literal
(Ptyp
))),
3386 Make_Function_Call
(Loc
,
3389 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
3391 Parameter_Associations
=>
3393 Unchecked_Convert_To
(Ptyp
,
3394 Make_Op_Subtract
(Loc
,
3396 Unchecked_Convert_To
(Standard_Integer
,
3397 Relocate_Node
(First
(Exprs
))),
3399 Make_Integer_Literal
(Loc
, 1))),
3400 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
3403 -- Add Boolean parameter True, to request program errror if
3404 -- we have a bad representation on our hands. If checks are
3405 -- suppressed, then add False instead
3407 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
3409 Make_Indexed_Component
(Loc
,
3412 (Enum_Pos_To_Rep
(Etyp
), Loc
),
3413 Expressions
=> New_List
(
3414 Make_Op_Subtract
(Loc
,
3416 Make_Function_Call
(Loc
,
3419 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
3420 Parameter_Associations
=> Exprs
),
3421 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
3424 Analyze_And_Resolve
(N
, Typ
);
3426 -- For floating-point, we transform 'Pred into a call to the Pred
3427 -- floating-point attribute function in Fat_xxx (xxx is root type)
3429 elsif Is_Floating_Point_Type
(Ptyp
) then
3430 Expand_Fpt_Attribute_R
(N
);
3431 Analyze_And_Resolve
(N
, Typ
);
3433 -- For modular types, nothing to do (no overflow, since wraps)
3435 elsif Is_Modular_Integer_Type
(Ptyp
) then
3438 -- For other types, if argument is marked as needing a range check or
3439 -- overflow checking is enabled, we must generate a check.
3441 elsif not Overflow_Checks_Suppressed
(Ptyp
)
3442 or else Do_Range_Check
(First
(Exprs
))
3444 Set_Do_Range_Check
(First
(Exprs
), False);
3445 Expand_Pred_Succ
(N
);
3453 -- Ada 2005 (AI-327): Dynamic ceiling priorities
3455 -- We rewrite X'Priority as the following run-time call:
3457 -- Get_Ceiling (X._Object)
3459 -- Note that although X'Priority is notionally an object, it is quite
3460 -- deliberately not defined as an aliased object in the RM. This means
3461 -- that it works fine to rewrite it as a call, without having to worry
3462 -- about complications that would other arise from X'Priority'Access,
3463 -- which is illegal, because of the lack of aliasing.
3465 when Attribute_Priority
=>
3468 Conctyp
: Entity_Id
;
3469 Object_Parm
: Node_Id
;
3471 RT_Subprg_Name
: Node_Id
;
3474 -- Look for the enclosing concurrent type
3476 Conctyp
:= Current_Scope
;
3477 while not Is_Concurrent_Type
(Conctyp
) loop
3478 Conctyp
:= Scope
(Conctyp
);
3481 pragma Assert
(Is_Protected_Type
(Conctyp
));
3483 -- Generate the actual of the call
3485 Subprg
:= Current_Scope
;
3486 while not Present
(Protected_Body_Subprogram
(Subprg
)) loop
3487 Subprg
:= Scope
(Subprg
);
3490 -- Use of 'Priority inside protected entries and barriers (in
3491 -- both cases the type of the first formal of their expanded
3492 -- subprogram is Address)
3494 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
)))
3498 New_Itype
: Entity_Id
;
3501 -- In the expansion of protected entries the type of the
3502 -- first formal of the Protected_Body_Subprogram is an
3503 -- Address. In order to reference the _object component
3506 -- type T is access p__ptTV;
3509 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
3510 Set_Etype
(New_Itype
, New_Itype
);
3511 Set_Directly_Designated_Type
(New_Itype
,
3512 Corresponding_Record_Type
(Conctyp
));
3513 Freeze_Itype
(New_Itype
, N
);
3516 -- T!(O)._object'unchecked_access
3519 Make_Attribute_Reference
(Loc
,
3521 Make_Selected_Component
(Loc
,
3523 Unchecked_Convert_To
(New_Itype
,
3526 (Protected_Body_Subprogram
(Subprg
)),
3529 Make_Identifier
(Loc
, Name_uObject
)),
3530 Attribute_Name
=> Name_Unchecked_Access
);
3533 -- Use of 'Priority inside a protected subprogram
3537 Make_Attribute_Reference
(Loc
,
3539 Make_Selected_Component
(Loc
,
3540 Prefix
=> New_Reference_To
3542 (Protected_Body_Subprogram
(Subprg
)),
3545 Make_Identifier
(Loc
, Name_uObject
)),
3546 Attribute_Name
=> Name_Unchecked_Access
);
3549 -- Select the appropriate run-time subprogram
3551 if Number_Entries
(Conctyp
) = 0 then
3553 New_Reference_To
(RTE
(RE_Get_Ceiling
), Loc
);
3556 New_Reference_To
(RTE
(RO_PE_Get_Ceiling
), Loc
);
3560 Make_Function_Call
(Loc
,
3561 Name
=> RT_Subprg_Name
,
3562 Parameter_Associations
=> New_List
(Object_Parm
));
3566 -- Avoid the generation of extra checks on the pointer to the
3567 -- protected object.
3569 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
3576 when Attribute_Range_Length
=> Range_Length
: begin
3578 -- The only special processing required is for the case where
3579 -- Range_Length is applied to an enumeration type with holes.
3580 -- In this case we transform
3586 -- X'Pos (X'Last) - X'Pos (X'First) + 1
3588 -- So that the result reflects the proper Pos values instead
3589 -- of the underlying representations.
3591 if Is_Enumeration_Type
(Ptyp
)
3592 and then Has_Non_Standard_Rep
(Ptyp
)
3597 Make_Op_Subtract
(Loc
,
3599 Make_Attribute_Reference
(Loc
,
3600 Attribute_Name
=> Name_Pos
,
3601 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3602 Expressions
=> New_List
(
3603 Make_Attribute_Reference
(Loc
,
3604 Attribute_Name
=> Name_Last
,
3605 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
)))),
3608 Make_Attribute_Reference
(Loc
,
3609 Attribute_Name
=> Name_Pos
,
3610 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3611 Expressions
=> New_List
(
3612 Make_Attribute_Reference
(Loc
,
3613 Attribute_Name
=> Name_First
,
3614 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
))))),
3616 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
3618 Analyze_And_Resolve
(N
, Typ
);
3620 -- For all other cases, the attribute is handled by the back end, but
3621 -- we need to deal with the case of the range check on a universal
3625 Apply_Universal_Integer_Attribute_Checks
(N
);
3633 when Attribute_Read
=> Read
: declare
3634 P_Type
: constant Entity_Id
:= Entity
(Pref
);
3635 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
3636 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
3646 -- If no underlying type, we have an error that will be diagnosed
3647 -- elsewhere, so here we just completely ignore the expansion.
3653 -- The simple case, if there is a TSS for Read, just call it
3655 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
);
3657 if Present
(Pname
) then
3661 -- If there is a Stream_Convert pragma, use it, we rewrite
3663 -- sourcetyp'Read (stream, Item)
3667 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3669 -- where strmread is the given Read function that converts an
3670 -- argument of type strmtyp to type sourcetyp or a type from which
3671 -- it is derived. The conversion to sourcetyp is required in the
3674 -- A special case arises if Item is a type conversion in which
3675 -- case, we have to expand to:
3677 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
3679 -- where Itemx is the expression of the type conversion (i.e.
3680 -- the actual object), and typex is the type of Itemx.
3682 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
3684 if Present
(Prag
) then
3685 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
3686 Rfunc
:= Entity
(Expression
(Arg2
));
3687 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
3689 OK_Convert_To
(B_Type
,
3690 Make_Function_Call
(Loc
,
3691 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
3692 Parameter_Associations
=> New_List
(
3693 Make_Attribute_Reference
(Loc
,
3696 (Etype
(First_Formal
(Rfunc
)), Loc
),
3697 Attribute_Name
=> Name_Input
,
3698 Expressions
=> New_List
(
3699 Relocate_Node
(First
(Exprs
)))))));
3701 if Nkind
(Lhs
) = N_Type_Conversion
then
3702 Lhs
:= Expression
(Lhs
);
3703 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
3707 Make_Assignment_Statement
(Loc
,
3709 Expression
=> Rhs
));
3710 Set_Assignment_OK
(Lhs
);
3714 -- For elementary types, we call the I_xxx routine using the first
3715 -- parameter and then assign the result into the second parameter.
3716 -- We set Assignment_OK to deal with the conversion case.
3718 elsif Is_Elementary_Type
(U_Type
) then
3724 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
3725 Rhs
:= Build_Elementary_Input_Call
(N
);
3727 if Nkind
(Lhs
) = N_Type_Conversion
then
3728 Lhs
:= Expression
(Lhs
);
3729 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
3732 Set_Assignment_OK
(Lhs
);
3735 Make_Assignment_Statement
(Loc
,
3737 Expression
=> Rhs
));
3745 elsif Is_Array_Type
(U_Type
) then
3746 Build_Array_Read_Procedure
(N
, U_Type
, Decl
, Pname
);
3747 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
3749 -- Tagged type case, use the primitive Read function. Note that
3750 -- this will dispatch in the class-wide case which is what we want
3752 elsif Is_Tagged_Type
(U_Type
) then
3753 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
3755 -- All other record type cases, including protected records. The
3756 -- latter only arise for expander generated code for handling
3757 -- shared passive partition access.
3761 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
3763 -- Ada 2005 (AI-216): Program_Error is raised when executing
3764 -- the default implementation of the Read attribute of an
3765 -- Unchecked_Union type.
3767 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
3769 Make_Raise_Program_Error
(Loc
,
3770 Reason
=> PE_Unchecked_Union_Restriction
));
3773 if Has_Discriminants
(U_Type
)
3775 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
3777 Build_Mutable_Record_Read_Procedure
3778 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
3780 Build_Record_Read_Procedure
3781 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
3784 -- Suppress checks, uninitialized or otherwise invalid
3785 -- data does not cause constraint errors to be raised for
3786 -- a complete record read.
3788 Insert_Action
(N
, Decl
, All_Checks
);
3792 Rewrite_Stream_Proc_Call
(Pname
);
3799 -- Ref is identical to To_Address, see To_Address for processing
3805 -- Transforms 'Remainder into a call to the floating-point attribute
3806 -- function Remainder in Fat_xxx (where xxx is the root type)
3808 when Attribute_Remainder
=>
3809 Expand_Fpt_Attribute_RR
(N
);
3815 -- Transform 'Result into reference to _Result formal. At the point
3816 -- where a legal 'Result attribute is expanded, we know that we are in
3817 -- the context of a _Postcondition function with a _Result parameter.
3819 when Attribute_Result
=>
3820 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
3821 Analyze_And_Resolve
(N
, Typ
);
3827 -- The handling of the Round attribute is quite delicate. The processing
3828 -- in Sem_Attr introduced a conversion to universal real, reflecting the
3829 -- semantics of Round, but we do not want anything to do with universal
3830 -- real at runtime, since this corresponds to using floating-point
3833 -- What we have now is that the Etype of the Round attribute correctly
3834 -- indicates the final result type. The operand of the Round is the
3835 -- conversion to universal real, described above, and the operand of
3836 -- this conversion is the actual operand of Round, which may be the
3837 -- special case of a fixed point multiplication or division (Etype =
3840 -- The exapander will expand first the operand of the conversion, then
3841 -- the conversion, and finally the round attribute itself, since we
3842 -- always work inside out. But we cannot simply process naively in this
3843 -- order. In the semantic world where universal fixed and real really
3844 -- exist and have infinite precision, there is no problem, but in the
3845 -- implementation world, where universal real is a floating-point type,
3846 -- we would get the wrong result.
3848 -- So the approach is as follows. First, when expanding a multiply or
3849 -- divide whose type is universal fixed, we do nothing at all, instead
3850 -- deferring the operation till later.
3852 -- The actual processing is done in Expand_N_Type_Conversion which
3853 -- handles the special case of Round by looking at its parent to see if
3854 -- it is a Round attribute, and if it is, handling the conversion (or
3855 -- its fixed multiply/divide child) in an appropriate manner.
3857 -- This means that by the time we get to expanding the Round attribute
3858 -- itself, the Round is nothing more than a type conversion (and will
3859 -- often be a null type conversion), so we just replace it with the
3860 -- appropriate conversion operation.
3862 when Attribute_Round
=>
3864 Convert_To
(Etype
(N
), Relocate_Node
(First
(Exprs
))));
3865 Analyze_And_Resolve
(N
);
3871 -- Transforms 'Rounding into a call to the floating-point attribute
3872 -- function Rounding in Fat_xxx (where xxx is the root type)
3874 when Attribute_Rounding
=>
3875 Expand_Fpt_Attribute_R
(N
);
3881 -- Transforms 'Scaling into a call to the floating-point attribute
3882 -- function Scaling in Fat_xxx (where xxx is the root type)
3884 when Attribute_Scaling
=>
3885 Expand_Fpt_Attribute_RI
(N
);
3891 when Attribute_Size |
3892 Attribute_Object_Size |
3893 Attribute_Value_Size |
3894 Attribute_VADS_Size
=> Size
:
3901 -- Processing for VADS_Size case. Note that this processing removes
3902 -- all traces of VADS_Size from the tree, and completes all required
3903 -- processing for VADS_Size by translating the attribute reference
3904 -- to an appropriate Size or Object_Size reference.
3906 if Id
= Attribute_VADS_Size
3907 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
3909 -- If the size is specified, then we simply use the specified
3910 -- size. This applies to both types and objects. The size of an
3911 -- object can be specified in the following ways:
3913 -- An explicit size object is given for an object
3914 -- A component size is specified for an indexed component
3915 -- A component clause is specified for a selected component
3916 -- The object is a component of a packed composite object
3918 -- If the size is specified, then VADS_Size of an object
3920 if (Is_Entity_Name
(Pref
)
3921 and then Present
(Size_Clause
(Entity
(Pref
))))
3923 (Nkind
(Pref
) = N_Component_Clause
3924 and then (Present
(Component_Clause
3925 (Entity
(Selector_Name
(Pref
))))
3926 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
3928 (Nkind
(Pref
) = N_Indexed_Component
3929 and then (Component_Size
(Etype
(Prefix
(Pref
))) /= 0
3930 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
3932 Set_Attribute_Name
(N
, Name_Size
);
3934 -- Otherwise if we have an object rather than a type, then the
3935 -- VADS_Size attribute applies to the type of the object, rather
3936 -- than the object itself. This is one of the respects in which
3937 -- VADS_Size differs from Size.
3940 if (not Is_Entity_Name
(Pref
)
3941 or else not Is_Type
(Entity
(Pref
)))
3942 and then (Is_Scalar_Type
(Ptyp
) or else Is_Constrained
(Ptyp
))
3944 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
3947 -- For a scalar type for which no size was explicitly given,
3948 -- VADS_Size means Object_Size. This is the other respect in
3949 -- which VADS_Size differs from Size.
3951 if Is_Scalar_Type
(Ptyp
) and then No
(Size_Clause
(Ptyp
)) then
3952 Set_Attribute_Name
(N
, Name_Object_Size
);
3954 -- In all other cases, Size and VADS_Size are the sane
3957 Set_Attribute_Name
(N
, Name_Size
);
3962 -- For class-wide types, X'Class'Size is transformed into a direct
3963 -- reference to the Size of the class type, so that the back end does
3964 -- not have to deal with the X'Class'Size reference.
3966 if Is_Entity_Name
(Pref
)
3967 and then Is_Class_Wide_Type
(Entity
(Pref
))
3969 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
3972 -- For X'Size applied to an object of a class-wide type, transform
3973 -- X'Size into a call to the primitive operation _Size applied to X.
3975 elsif Is_Class_Wide_Type
(Ptyp
)
3976 or else (Id
= Attribute_Size
3977 and then Is_Tagged_Type
(Ptyp
)
3978 and then Has_Unknown_Discriminants
(Ptyp
))
3980 -- No need to do anything else compiling under restriction
3981 -- No_Dispatching_Calls. During the semantic analysis we
3982 -- already notified such violation.
3984 if Restriction_Active
(No_Dispatching_Calls
) then
3989 Make_Function_Call
(Loc
,
3990 Name
=> New_Reference_To
3991 (Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
3992 Parameter_Associations
=> New_List
(Pref
));
3994 if Typ
/= Standard_Long_Long_Integer
then
3996 -- The context is a specific integer type with which the
3997 -- original attribute was compatible. The function has a
3998 -- specific type as well, so to preserve the compatibility
3999 -- we must convert explicitly.
4001 New_Node
:= Convert_To
(Typ
, New_Node
);
4004 Rewrite
(N
, New_Node
);
4005 Analyze_And_Resolve
(N
, Typ
);
4008 -- Case of known RM_Size of a type
4010 elsif (Id
= Attribute_Size
or else Id
= Attribute_Value_Size
)
4011 and then Is_Entity_Name
(Pref
)
4012 and then Is_Type
(Entity
(Pref
))
4013 and then Known_Static_RM_Size
(Entity
(Pref
))
4015 Siz
:= RM_Size
(Entity
(Pref
));
4017 -- Case of known Esize of a type
4019 elsif Id
= Attribute_Object_Size
4020 and then Is_Entity_Name
(Pref
)
4021 and then Is_Type
(Entity
(Pref
))
4022 and then Known_Static_Esize
(Entity
(Pref
))
4024 Siz
:= Esize
(Entity
(Pref
));
4026 -- Case of known size of object
4028 elsif Id
= Attribute_Size
4029 and then Is_Entity_Name
(Pref
)
4030 and then Is_Object
(Entity
(Pref
))
4031 and then Known_Esize
(Entity
(Pref
))
4032 and then Known_Static_Esize
(Entity
(Pref
))
4034 Siz
:= Esize
(Entity
(Pref
));
4036 -- For an array component, we can do Size in the front end
4037 -- if the component_size of the array is set.
4039 elsif Nkind
(Pref
) = N_Indexed_Component
then
4040 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
4042 -- For a record component, we can do Size in the front end if there
4043 -- is a component clause, or if the record is packed and the
4044 -- component's size is known at compile time.
4046 elsif Nkind
(Pref
) = N_Selected_Component
then
4048 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
4049 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
4052 if Present
(Component_Clause
(Comp
)) then
4053 Siz
:= Esize
(Comp
);
4055 elsif Is_Packed
(Rec
) then
4056 Siz
:= RM_Size
(Ptyp
);
4059 Apply_Universal_Integer_Attribute_Checks
(N
);
4064 -- All other cases are handled by the back end
4067 Apply_Universal_Integer_Attribute_Checks
(N
);
4069 -- If Size is applied to a formal parameter that is of a packed
4070 -- array subtype, then apply Size to the actual subtype.
4072 if Is_Entity_Name
(Pref
)
4073 and then Is_Formal
(Entity
(Pref
))
4074 and then Is_Array_Type
(Ptyp
)
4075 and then Is_Packed
(Ptyp
)
4078 Make_Attribute_Reference
(Loc
,
4080 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
4081 Attribute_Name
=> Name_Size
));
4082 Analyze_And_Resolve
(N
, Typ
);
4085 -- If Size applies to a dereference of an access to unconstrained
4086 -- packed array, the back end needs to see its unconstrained
4087 -- nominal type, but also a hint to the actual constrained type.
4089 if Nkind
(Pref
) = N_Explicit_Dereference
4090 and then Is_Array_Type
(Ptyp
)
4091 and then not Is_Constrained
(Ptyp
)
4092 and then Is_Packed
(Ptyp
)
4094 Set_Actual_Designated_Subtype
(Pref
,
4095 Get_Actual_Subtype
(Pref
));
4101 -- Common processing for record and array component case
4103 if Siz
/= No_Uint
and then Siz
/= 0 then
4105 CS
: constant Boolean := Comes_From_Source
(N
);
4108 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
4110 -- This integer literal is not a static expression. We do not
4111 -- call Analyze_And_Resolve here, because this would activate
4112 -- the circuit for deciding that a static value was out of
4113 -- range, and we don't want that.
4115 -- So just manually set the type, mark the expression as non-
4116 -- static, and then ensure that the result is checked properly
4117 -- if the attribute comes from source (if it was internally
4118 -- generated, we never need a constraint check).
4121 Set_Is_Static_Expression
(N
, False);
4124 Apply_Constraint_Check
(N
, Typ
);
4134 when Attribute_Storage_Pool
=>
4136 Make_Type_Conversion
(Loc
,
4137 Subtype_Mark
=> New_Reference_To
(Etype
(N
), Loc
),
4138 Expression
=> New_Reference_To
(Entity
(N
), Loc
)));
4139 Analyze_And_Resolve
(N
, Typ
);
4145 when Attribute_Storage_Size
=> Storage_Size
: begin
4147 -- Access type case, always go to the root type
4149 -- The case of access types results in a value of zero for the case
4150 -- where no storage size attribute clause has been given. If a
4151 -- storage size has been given, then the attribute is converted
4152 -- to a reference to the variable used to hold this value.
4154 if Is_Access_Type
(Ptyp
) then
4155 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
4157 Make_Attribute_Reference
(Loc
,
4158 Prefix
=> New_Reference_To
(Typ
, Loc
),
4159 Attribute_Name
=> Name_Max
,
4160 Expressions
=> New_List
(
4161 Make_Integer_Literal
(Loc
, 0),
4164 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
4166 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
4169 Make_Function_Call
(Loc
,
4173 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
4174 Attribute_Name
(N
)),
4177 Parameter_Associations
=> New_List
(
4179 (Associated_Storage_Pool
(Root_Type
(Ptyp
)), Loc
)))));
4182 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
4185 Analyze_And_Resolve
(N
, Typ
);
4187 -- For tasks, we retrieve the size directly from the TCB. The
4188 -- size may depend on a discriminant of the type, and therefore
4189 -- can be a per-object expression, so type-level information is
4190 -- not sufficient in general. There are four cases to consider:
4192 -- a) If the attribute appears within a task body, the designated
4193 -- TCB is obtained by a call to Self.
4195 -- b) If the prefix of the attribute is the name of a task object,
4196 -- the designated TCB is the one stored in the corresponding record.
4198 -- c) If the prefix is a task type, the size is obtained from the
4199 -- size variable created for each task type
4201 -- d) If no storage_size was specified for the type , there is no
4202 -- size variable, and the value is a system-specific default.
4205 if In_Open_Scopes
(Ptyp
) then
4207 -- Storage_Size (Self)
4211 Make_Function_Call
(Loc
,
4213 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
4214 Parameter_Associations
=>
4216 Make_Function_Call
(Loc
,
4218 New_Reference_To
(RTE
(RE_Self
), Loc
))))));
4220 elsif not Is_Entity_Name
(Pref
)
4221 or else not Is_Type
(Entity
(Pref
))
4223 -- Storage_Size (Rec (Obj).Size)
4227 Make_Function_Call
(Loc
,
4229 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
4230 Parameter_Associations
=>
4232 Make_Selected_Component
(Loc
,
4234 Unchecked_Convert_To
(
4235 Corresponding_Record_Type
(Ptyp
),
4236 New_Copy_Tree
(Pref
)),
4238 Make_Identifier
(Loc
, Name_uTask_Id
))))));
4240 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
4242 -- Static storage size pragma given for type: retrieve value
4243 -- from its allocated storage variable.
4247 Make_Function_Call
(Loc
,
4248 Name
=> New_Occurrence_Of
(
4249 RTE
(RE_Adjust_Storage_Size
), Loc
),
4250 Parameter_Associations
=>
4253 Storage_Size_Variable
(Ptyp
), Loc
)))));
4255 -- Get system default
4259 Make_Function_Call
(Loc
,
4262 RTE
(RE_Default_Stack_Size
), Loc
))));
4265 Analyze_And_Resolve
(N
, Typ
);
4273 when Attribute_Stream_Size
=> Stream_Size
: declare
4277 -- If we have a Stream_Size clause for this type use it, otherwise
4278 -- the Stream_Size if the size of the type.
4280 if Has_Stream_Size_Clause
(Ptyp
) then
4283 (Static_Integer
(Expression
(Stream_Size_Clause
(Ptyp
))));
4285 Size
:= UI_To_Int
(Esize
(Ptyp
));
4288 Rewrite
(N
, Make_Integer_Literal
(Loc
, Intval
=> Size
));
4289 Analyze_And_Resolve
(N
, Typ
);
4296 -- 1. Deal with enumeration types with holes
4297 -- 2. For floating-point, generate call to attribute function
4298 -- 3. For other cases, deal with constraint checking
4300 when Attribute_Succ
=> Succ
: declare
4301 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
4305 -- For enumeration types with non-standard representations, we
4306 -- expand typ'Succ (x) into
4308 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
4310 -- If the representation is contiguous, we compute instead
4311 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4313 if Is_Enumeration_Type
(Ptyp
)
4314 and then Present
(Enum_Pos_To_Rep
(Etyp
))
4316 if Has_Contiguous_Rep
(Etyp
) then
4318 Unchecked_Convert_To
(Ptyp
,
4321 Make_Integer_Literal
(Loc
,
4322 Enumeration_Rep
(First_Literal
(Ptyp
))),
4324 Make_Function_Call
(Loc
,
4327 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4329 Parameter_Associations
=>
4331 Unchecked_Convert_To
(Ptyp
,
4334 Unchecked_Convert_To
(Standard_Integer
,
4335 Relocate_Node
(First
(Exprs
))),
4337 Make_Integer_Literal
(Loc
, 1))),
4338 Rep_To_Pos_Flag
(Ptyp
, Loc
))))));
4340 -- Add Boolean parameter True, to request program errror if
4341 -- we have a bad representation on our hands. Add False if
4342 -- checks are suppressed.
4344 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
4346 Make_Indexed_Component
(Loc
,
4349 (Enum_Pos_To_Rep
(Etyp
), Loc
),
4350 Expressions
=> New_List
(
4353 Make_Function_Call
(Loc
,
4356 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4357 Parameter_Associations
=> Exprs
),
4358 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4361 Analyze_And_Resolve
(N
, Typ
);
4363 -- For floating-point, we transform 'Succ into a call to the Succ
4364 -- floating-point attribute function in Fat_xxx (xxx is root type)
4366 elsif Is_Floating_Point_Type
(Ptyp
) then
4367 Expand_Fpt_Attribute_R
(N
);
4368 Analyze_And_Resolve
(N
, Typ
);
4370 -- For modular types, nothing to do (no overflow, since wraps)
4372 elsif Is_Modular_Integer_Type
(Ptyp
) then
4375 -- For other types, if argument is marked as needing a range check or
4376 -- overflow checking is enabled, we must generate a check.
4378 elsif not Overflow_Checks_Suppressed
(Ptyp
)
4379 or else Do_Range_Check
(First
(Exprs
))
4381 Set_Do_Range_Check
(First
(Exprs
), False);
4382 Expand_Pred_Succ
(N
);
4390 -- Transforms X'Tag into a direct reference to the tag of X
4392 when Attribute_Tag
=> Tag
: declare
4394 Prefix_Is_Type
: Boolean;
4397 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
4398 Ttyp
:= Entity
(Pref
);
4399 Prefix_Is_Type
:= True;
4402 Prefix_Is_Type
:= False;
4405 if Is_Class_Wide_Type
(Ttyp
) then
4406 Ttyp
:= Root_Type
(Ttyp
);
4409 Ttyp
:= Underlying_Type
(Ttyp
);
4411 -- Ada 2005: The type may be a synchronized tagged type, in which
4412 -- case the tag information is stored in the corresponding record.
4414 if Is_Concurrent_Type
(Ttyp
) then
4415 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
4418 if Prefix_Is_Type
then
4420 -- For VMs we leave the type attribute unexpanded because
4421 -- there's not a dispatching table to reference.
4423 if Tagged_Type_Expansion
then
4425 Unchecked_Convert_To
(RTE
(RE_Tag
),
4427 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
4428 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
4431 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
4432 -- references the primary tag of the actual object. If 'Tag is
4433 -- applied to class-wide interface objects we generate code that
4434 -- displaces "this" to reference the base of the object.
4436 elsif Comes_From_Source
(N
)
4437 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
4438 and then Is_Interface
(Etype
(Prefix
(N
)))
4441 -- (To_Tag_Ptr (Prefix'Address)).all
4443 -- Note that Prefix'Address is recursively expanded into a call
4444 -- to Base_Address (Obj.Tag)
4446 -- Not needed for VM targets, since all handled by the VM
4448 if Tagged_Type_Expansion
then
4450 Make_Explicit_Dereference
(Loc
,
4451 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
4452 Make_Attribute_Reference
(Loc
,
4453 Prefix
=> Relocate_Node
(Pref
),
4454 Attribute_Name
=> Name_Address
))));
4455 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
4460 Make_Selected_Component
(Loc
,
4461 Prefix
=> Relocate_Node
(Pref
),
4463 New_Reference_To
(First_Tag_Component
(Ttyp
), Loc
)));
4464 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
4472 -- Transforms 'Terminated attribute into a call to Terminated function
4474 when Attribute_Terminated
=> Terminated
:
4476 -- The prefix of Terminated is of a task interface class-wide type.
4478 -- terminated (Task_Id (Pref._disp_get_task_id));
4480 if Ada_Version
>= Ada_2005
4481 and then Ekind
(Ptyp
) = E_Class_Wide_Type
4482 and then Is_Interface
(Ptyp
)
4483 and then Is_Task_Interface
(Ptyp
)
4486 Make_Function_Call
(Loc
,
4488 New_Reference_To
(RTE
(RE_Terminated
), Loc
),
4489 Parameter_Associations
=> New_List
(
4490 Make_Unchecked_Type_Conversion
(Loc
,
4492 New_Reference_To
(RTE
(RO_ST_Task_Id
), Loc
),
4494 Make_Selected_Component
(Loc
,
4496 New_Copy_Tree
(Pref
),
4498 Make_Identifier
(Loc
, Name_uDisp_Get_Task_Id
))))));
4500 elsif Restricted_Profile
then
4502 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
4506 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
4509 Analyze_And_Resolve
(N
, Standard_Boolean
);
4516 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
4517 -- unchecked conversion from (integral) type of X to type address.
4519 when Attribute_To_Address | Attribute_Ref
=>
4521 Unchecked_Convert_To
(RTE
(RE_Address
),
4522 Relocate_Node
(First
(Exprs
))));
4523 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
4529 when Attribute_To_Any
=> To_Any
: declare
4530 P_Type
: constant Entity_Id
:= Etype
(Pref
);
4531 Decls
: constant List_Id
:= New_List
;
4535 (Convert_To
(P_Type
,
4536 Relocate_Node
(First
(Exprs
))), Decls
));
4537 Insert_Actions
(N
, Decls
);
4538 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
4545 -- Transforms 'Truncation into a call to the floating-point attribute
4546 -- function Truncation in Fat_xxx (where xxx is the root type).
4547 -- Expansion is avoided for cases the back end can handle directly.
4549 when Attribute_Truncation
=>
4550 if not Is_Inline_Floating_Point_Attribute
(N
) then
4551 Expand_Fpt_Attribute_R
(N
);
4558 when Attribute_TypeCode
=> TypeCode
: declare
4559 P_Type
: constant Entity_Id
:= Etype
(Pref
);
4560 Decls
: constant List_Id
:= New_List
;
4562 Rewrite
(N
, Build_TypeCode_Call
(Loc
, P_Type
, Decls
));
4563 Insert_Actions
(N
, Decls
);
4564 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
4567 -----------------------
4568 -- Unbiased_Rounding --
4569 -----------------------
4571 -- Transforms 'Unbiased_Rounding into a call to the floating-point
4572 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4573 -- root type). Expansion is avoided for cases the back end can handle
4576 when Attribute_Unbiased_Rounding
=>
4577 if not Is_Inline_Floating_Point_Attribute
(N
) then
4578 Expand_Fpt_Attribute_R
(N
);
4585 when Attribute_UET_Address
=> UET_Address
: declare
4586 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
4590 Make_Object_Declaration
(Loc
,
4591 Defining_Identifier
=> Ent
,
4592 Aliased_Present
=> True,
4593 Object_Definition
=>
4594 New_Occurrence_Of
(RTE
(RE_Address
), Loc
)));
4596 -- Construct name __gnat_xxx__SDP, where xxx is the unit name
4597 -- in normal external form.
4599 Get_External_Unit_Name_String
(Get_Unit_Name
(Pref
));
4600 Name_Buffer
(1 + 7 .. Name_Len
+ 7) := Name_Buffer
(1 .. Name_Len
);
4601 Name_Len
:= Name_Len
+ 7;
4602 Name_Buffer
(1 .. 7) := "__gnat_";
4603 Name_Buffer
(Name_Len
+ 1 .. Name_Len
+ 5) := "__SDP";
4604 Name_Len
:= Name_Len
+ 5;
4606 Set_Is_Imported
(Ent
);
4607 Set_Interface_Name
(Ent
,
4608 Make_String_Literal
(Loc
,
4609 Strval
=> String_From_Name_Buffer
));
4611 -- Set entity as internal to ensure proper Sprint output of its
4612 -- implicit importation.
4614 Set_Is_Internal
(Ent
);
4617 Make_Attribute_Reference
(Loc
,
4618 Prefix
=> New_Occurrence_Of
(Ent
, Loc
),
4619 Attribute_Name
=> Name_Address
));
4621 Analyze_And_Resolve
(N
, Typ
);
4628 -- The processing for VADS_Size is shared with Size
4634 -- For enumeration types with a standard representation, and for all
4635 -- other types, Val is handled by the back end. For enumeration types
4636 -- with a non-standard representation we use the _Pos_To_Rep array that
4637 -- was created when the type was frozen.
4639 when Attribute_Val
=> Val
: declare
4640 Etyp
: constant Entity_Id
:= Base_Type
(Entity
(Pref
));
4643 if Is_Enumeration_Type
(Etyp
)
4644 and then Present
(Enum_Pos_To_Rep
(Etyp
))
4646 if Has_Contiguous_Rep
(Etyp
) then
4648 Rep_Node
: constant Node_Id
:=
4649 Unchecked_Convert_To
(Etyp
,
4652 Make_Integer_Literal
(Loc
,
4653 Enumeration_Rep
(First_Literal
(Etyp
))),
4655 (Convert_To
(Standard_Integer
,
4656 Relocate_Node
(First
(Exprs
))))));
4660 Unchecked_Convert_To
(Etyp
,
4663 Make_Integer_Literal
(Loc
,
4664 Enumeration_Rep
(First_Literal
(Etyp
))),
4666 Make_Function_Call
(Loc
,
4669 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
4670 Parameter_Associations
=> New_List
(
4672 Rep_To_Pos_Flag
(Etyp
, Loc
))))));
4677 Make_Indexed_Component
(Loc
,
4678 Prefix
=> New_Reference_To
(Enum_Pos_To_Rep
(Etyp
), Loc
),
4679 Expressions
=> New_List
(
4680 Convert_To
(Standard_Integer
,
4681 Relocate_Node
(First
(Exprs
))))));
4684 Analyze_And_Resolve
(N
, Typ
);
4686 -- If the argument is marked as requiring a range check then generate
4689 elsif Do_Range_Check
(First
(Exprs
)) then
4690 Set_Do_Range_Check
(First
(Exprs
), False);
4691 Generate_Range_Check
(First
(Exprs
), Etyp
, CE_Range_Check_Failed
);
4699 -- The code for valid is dependent on the particular types involved.
4700 -- See separate sections below for the generated code in each case.
4702 when Attribute_Valid
=> Valid
: declare
4703 Btyp
: Entity_Id
:= Base_Type
(Ptyp
);
4706 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
4707 -- Save the validity checking mode. We always turn off validity
4708 -- checking during process of 'Valid since this is one place
4709 -- where we do not want the implicit validity checks to intefere
4710 -- with the explicit validity check that the programmer is doing.
4712 function Make_Range_Test
return Node_Id
;
4713 -- Build the code for a range test of the form
4714 -- Btyp!(Pref) >= Btyp!(Ptyp'First)
4716 -- Btyp!(Pref) <= Btyp!(Ptyp'Last)
4718 ---------------------
4719 -- Make_Range_Test --
4720 ---------------------
4722 function Make_Range_Test
return Node_Id
is
4723 Temp
: constant Node_Id
:= Duplicate_Subexpr
(Pref
);
4726 -- The value whose validity is being checked has been captured in
4727 -- an object declaration. We certainly don't want this object to
4728 -- appear valid because the declaration initializes it!
4730 if Is_Entity_Name
(Temp
) then
4731 Set_Is_Known_Valid
(Entity
(Temp
), False);
4739 Unchecked_Convert_To
(Btyp
, Temp
),
4742 Unchecked_Convert_To
(Btyp
,
4743 Make_Attribute_Reference
(Loc
,
4744 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4745 Attribute_Name
=> Name_First
))),
4750 Unchecked_Convert_To
(Btyp
, Temp
),
4753 Unchecked_Convert_To
(Btyp
,
4754 Make_Attribute_Reference
(Loc
,
4755 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4756 Attribute_Name
=> Name_Last
))));
4757 end Make_Range_Test
;
4759 -- Start of processing for Attribute_Valid
4762 -- Do not expand sourced code 'Valid reference in CodePeer mode,
4763 -- will be handled by the back-end directly.
4765 if CodePeer_Mode
and then Comes_From_Source
(N
) then
4769 -- Turn off validity checks. We do not want any implicit validity
4770 -- checks to intefere with the explicit check from the attribute
4772 Validity_Checks_On
:= False;
4774 -- Floating-point case. This case is handled by the Valid attribute
4775 -- code in the floating-point attribute run-time library.
4777 if Is_Floating_Point_Type
(Ptyp
) then
4783 -- For vax fpt types, call appropriate routine in special vax
4784 -- floating point unit. We do not have to worry about loads in
4785 -- this case, since these types have no signalling NaN's.
4787 if Vax_Float
(Btyp
) then
4788 Expand_Vax_Valid
(N
);
4790 -- The AAMP back end handles Valid for floating-point types
4792 elsif Is_AAMP_Float
(Btyp
) then
4793 Analyze_And_Resolve
(Pref
, Ptyp
);
4794 Set_Etype
(N
, Standard_Boolean
);
4797 -- Non VAX float case
4800 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
4802 -- If the floating-point object might be unaligned, we need
4803 -- to call the special routine Unaligned_Valid, which makes
4804 -- the needed copy, being careful not to load the value into
4805 -- any floating-point register. The argument in this case is
4806 -- obj'Address (see Unaligned_Valid routine in Fat_Gen).
4808 if Is_Possibly_Unaligned_Object
(Pref
) then
4809 Expand_Fpt_Attribute
4810 (N
, Pkg
, Name_Unaligned_Valid
,
4812 Make_Attribute_Reference
(Loc
,
4813 Prefix
=> Relocate_Node
(Pref
),
4814 Attribute_Name
=> Name_Address
)));
4816 -- In the normal case where we are sure the object is
4817 -- aligned, we generate a call to Valid, and the argument in
4818 -- this case is obj'Unrestricted_Access (after converting
4819 -- obj to the right floating-point type).
4822 Expand_Fpt_Attribute
4823 (N
, Pkg
, Name_Valid
,
4825 Make_Attribute_Reference
(Loc
,
4826 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
4827 Attribute_Name
=> Name_Unrestricted_Access
)));
4831 -- One more task, we still need a range check. Required
4832 -- only if we have a constraint, since the Valid routine
4833 -- catches infinities properly (infinities are never valid).
4835 -- The way we do the range check is simply to create the
4836 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
4838 if not Subtypes_Statically_Match
(Ptyp
, Btyp
) then
4841 Left_Opnd
=> Relocate_Node
(N
),
4844 Left_Opnd
=> Convert_To
(Btyp
, Pref
),
4845 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
4849 -- Enumeration type with holes
4851 -- For enumeration types with holes, the Pos value constructed by
4852 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
4853 -- second argument of False returns minus one for an invalid value,
4854 -- and the non-negative pos value for a valid value, so the
4855 -- expansion of X'Valid is simply:
4857 -- type(X)'Pos (X) >= 0
4859 -- We can't quite generate it that way because of the requirement
4860 -- for the non-standard second argument of False in the resulting
4861 -- rep_to_pos call, so we have to explicitly create:
4863 -- _rep_to_pos (X, False) >= 0
4865 -- If we have an enumeration subtype, we also check that the
4866 -- value is in range:
4868 -- _rep_to_pos (X, False) >= 0
4870 -- (X >= type(X)'First and then type(X)'Last <= X)
4872 elsif Is_Enumeration_Type
(Ptyp
)
4873 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ptyp
)))
4878 Make_Function_Call
(Loc
,
4881 (TSS
(Base_Type
(Ptyp
), TSS_Rep_To_Pos
), Loc
),
4882 Parameter_Associations
=> New_List
(
4884 New_Occurrence_Of
(Standard_False
, Loc
))),
4885 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
4889 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(Btyp
)
4891 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(Btyp
))
4893 -- The call to Make_Range_Test will create declarations
4894 -- that need a proper insertion point, but Pref is now
4895 -- attached to a node with no ancestor. Attach to tree
4896 -- even if it is to be rewritten below.
4898 Set_Parent
(Tst
, Parent
(N
));
4902 Left_Opnd
=> Make_Range_Test
,
4908 -- Fortran convention booleans
4910 -- For the very special case of Fortran convention booleans, the
4911 -- value is always valid, since it is an integer with the semantics
4912 -- that non-zero is true, and any value is permissible.
4914 elsif Is_Boolean_Type
(Ptyp
)
4915 and then Convention
(Ptyp
) = Convention_Fortran
4917 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
4919 -- For biased representations, we will be doing an unchecked
4920 -- conversion without unbiasing the result. That means that the range
4921 -- test has to take this into account, and the proper form of the
4924 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
4926 elsif Has_Biased_Representation
(Ptyp
) then
4927 Btyp
:= RTE
(RE_Unsigned_32
);
4931 Unchecked_Convert_To
(Btyp
, Duplicate_Subexpr
(Pref
)),
4933 Unchecked_Convert_To
(Btyp
,
4934 Make_Attribute_Reference
(Loc
,
4935 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4936 Attribute_Name
=> Name_Range_Length
))));
4938 -- For all other scalar types, what we want logically is a
4941 -- X in type(X)'First .. type(X)'Last
4943 -- But that's precisely what won't work because of possible
4944 -- unwanted optimization (and indeed the basic motivation for
4945 -- the Valid attribute is exactly that this test does not work!)
4946 -- What will work is:
4948 -- Btyp!(X) >= Btyp!(type(X)'First)
4950 -- Btyp!(X) <= Btyp!(type(X)'Last)
4952 -- where Btyp is an integer type large enough to cover the full
4953 -- range of possible stored values (i.e. it is chosen on the basis
4954 -- of the size of the type, not the range of the values). We write
4955 -- this as two tests, rather than a range check, so that static
4956 -- evaluation will easily remove either or both of the checks if
4957 -- they can be -statically determined to be true (this happens
4958 -- when the type of X is static and the range extends to the full
4959 -- range of stored values).
4961 -- Unsigned types. Note: it is safe to consider only whether the
4962 -- subtype is unsigned, since we will in that case be doing all
4963 -- unsigned comparisons based on the subtype range. Since we use the
4964 -- actual subtype object size, this is appropriate.
4966 -- For example, if we have
4968 -- subtype x is integer range 1 .. 200;
4969 -- for x'Object_Size use 8;
4971 -- Now the base type is signed, but objects of this type are bits
4972 -- unsigned, and doing an unsigned test of the range 1 to 200 is
4973 -- correct, even though a value greater than 127 looks signed to a
4974 -- signed comparison.
4976 elsif Is_Unsigned_Type
(Ptyp
) then
4977 if Esize
(Ptyp
) <= 32 then
4978 Btyp
:= RTE
(RE_Unsigned_32
);
4980 Btyp
:= RTE
(RE_Unsigned_64
);
4983 Rewrite
(N
, Make_Range_Test
);
4988 if Esize
(Ptyp
) <= Esize
(Standard_Integer
) then
4989 Btyp
:= Standard_Integer
;
4991 Btyp
:= Universal_Integer
;
4994 Rewrite
(N
, Make_Range_Test
);
4997 Analyze_And_Resolve
(N
, Standard_Boolean
);
4998 Validity_Checks_On
:= Save_Validity_Checks_On
;
5005 -- Value attribute is handled in separate unti Exp_Imgv
5007 when Attribute_Value
=>
5008 Exp_Imgv
.Expand_Value_Attribute
(N
);
5014 -- The processing for Value_Size shares the processing for Size
5020 -- The processing for Version shares the processing for Body_Version
5026 -- Wide_Image attribute is handled in separate unit Exp_Imgv
5028 when Attribute_Wide_Image
=>
5029 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
5031 ---------------------
5032 -- Wide_Wide_Image --
5033 ---------------------
5035 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
5037 when Attribute_Wide_Wide_Image
=>
5038 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
5044 -- We expand typ'Wide_Value (X) into
5047 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
5049 -- Wide_String_To_String is a runtime function that converts its wide
5050 -- string argument to String, converting any non-translatable characters
5051 -- into appropriate escape sequences. This preserves the required
5052 -- semantics of Wide_Value in all cases, and results in a very simple
5053 -- implementation approach.
5055 -- Note: for this approach to be fully standard compliant for the cases
5056 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
5057 -- method must cover the entire character range (e.g. UTF-8). But that
5058 -- is a reasonable requirement when dealing with encoded character
5059 -- sequences. Presumably if one of the restrictive encoding mechanisms
5060 -- is in use such as Shift-JIS, then characters that cannot be
5061 -- represented using this encoding will not appear in any case.
5063 when Attribute_Wide_Value
=> Wide_Value
:
5066 Make_Attribute_Reference
(Loc
,
5068 Attribute_Name
=> Name_Value
,
5070 Expressions
=> New_List
(
5071 Make_Function_Call
(Loc
,
5073 New_Reference_To
(RTE
(RE_Wide_String_To_String
), Loc
),
5075 Parameter_Associations
=> New_List
(
5076 Relocate_Node
(First
(Exprs
)),
5077 Make_Integer_Literal
(Loc
,
5078 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
5080 Analyze_And_Resolve
(N
, Typ
);
5083 ---------------------
5084 -- Wide_Wide_Value --
5085 ---------------------
5087 -- We expand typ'Wide_Value_Value (X) into
5090 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
5092 -- Wide_Wide_String_To_String is a runtime function that converts its
5093 -- wide string argument to String, converting any non-translatable
5094 -- characters into appropriate escape sequences. This preserves the
5095 -- required semantics of Wide_Wide_Value in all cases, and results in a
5096 -- very simple implementation approach.
5098 -- It's not quite right where typ = Wide_Wide_Character, because the
5099 -- encoding method may not cover the whole character type ???
5101 when Attribute_Wide_Wide_Value
=> Wide_Wide_Value
:
5104 Make_Attribute_Reference
(Loc
,
5106 Attribute_Name
=> Name_Value
,
5108 Expressions
=> New_List
(
5109 Make_Function_Call
(Loc
,
5111 New_Reference_To
(RTE
(RE_Wide_Wide_String_To_String
), Loc
),
5113 Parameter_Associations
=> New_List
(
5114 Relocate_Node
(First
(Exprs
)),
5115 Make_Integer_Literal
(Loc
,
5116 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
5118 Analyze_And_Resolve
(N
, Typ
);
5119 end Wide_Wide_Value
;
5121 ---------------------
5122 -- Wide_Wide_Width --
5123 ---------------------
5125 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5127 when Attribute_Wide_Wide_Width
=>
5128 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
5134 -- Wide_Width attribute is handled in separate unit Exp_Imgv
5136 when Attribute_Wide_Width
=>
5137 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
5143 -- Width attribute is handled in separate unit Exp_Imgv
5145 when Attribute_Width
=>
5146 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
5152 when Attribute_Write
=> Write
: declare
5153 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5154 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5162 -- If no underlying type, we have an error that will be diagnosed
5163 -- elsewhere, so here we just completely ignore the expansion.
5169 -- The simple case, if there is a TSS for Write, just call it
5171 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
);
5173 if Present
(Pname
) then
5177 -- If there is a Stream_Convert pragma, use it, we rewrite
5179 -- sourcetyp'Output (stream, Item)
5183 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5185 -- where strmwrite is the given Write function that converts an
5186 -- argument of type sourcetyp or a type acctyp, from which it is
5187 -- derived to type strmtyp. The conversion to acttyp is required
5188 -- for the derived case.
5190 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5192 if Present
(Prag
) then
5194 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
5195 Wfunc
:= Entity
(Expression
(Arg3
));
5198 Make_Attribute_Reference
(Loc
,
5199 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
5200 Attribute_Name
=> Name_Output
,
5201 Expressions
=> New_List
(
5202 Relocate_Node
(First
(Exprs
)),
5203 Make_Function_Call
(Loc
,
5204 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
5205 Parameter_Associations
=> New_List
(
5206 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
5207 Relocate_Node
(Next
(First
(Exprs
)))))))));
5212 -- For elementary types, we call the W_xxx routine directly
5214 elsif Is_Elementary_Type
(U_Type
) then
5215 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
5221 elsif Is_Array_Type
(U_Type
) then
5222 Build_Array_Write_Procedure
(N
, U_Type
, Decl
, Pname
);
5223 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
, Check
=> False);
5225 -- Tagged type case, use the primitive Write function. Note that
5226 -- this will dispatch in the class-wide case which is what we want
5228 elsif Is_Tagged_Type
(U_Type
) then
5229 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
5231 -- All other record type cases, including protected records.
5232 -- The latter only arise for expander generated code for
5233 -- handling shared passive partition access.
5237 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5239 -- Ada 2005 (AI-216): Program_Error is raised when executing
5240 -- the default implementation of the Write attribute of an
5241 -- Unchecked_Union type. However, if the 'Write reference is
5242 -- within the generated Output stream procedure, Write outputs
5243 -- the components, and the default values of the discriminant
5244 -- are streamed by the Output procedure itself.
5246 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5247 and not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
5250 Make_Raise_Program_Error
(Loc
,
5251 Reason
=> PE_Unchecked_Union_Restriction
));
5254 if Has_Discriminants
(U_Type
)
5256 (Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5258 Build_Mutable_Record_Write_Procedure
5259 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5261 Build_Record_Write_Procedure
5262 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5265 Insert_Action
(N
, Decl
);
5269 -- If we fall through, Pname is the procedure to be called
5271 Rewrite_Stream_Proc_Call
(Pname
);
5274 -- Component_Size is handled by the back end, unless the component size
5275 -- is known at compile time, which is always true in the packed array
5276 -- case. It is important that the packed array case is handled in the
5277 -- front end (see Eval_Attribute) since the back end would otherwise get
5278 -- confused by the equivalent packed array type.
5280 when Attribute_Component_Size
=>
5283 -- The following attributes are handled by the back end (except that
5284 -- static cases have already been evaluated during semantic processing,
5285 -- but in any case the back end should not count on this). The one bit
5286 -- of special processing required is that these attributes typically
5287 -- generate conditionals in the code, so we need to check the relevant
5290 when Attribute_Max |
5292 Check_Restriction
(No_Implicit_Conditionals
, N
);
5294 -- The following attributes are handled by the back end (except that
5295 -- static cases have already been evaluated during semantic processing,
5296 -- but in any case the back end should not count on this).
5298 -- The back end also handles the non-class-wide cases of Size
5300 when Attribute_Bit_Order |
5301 Attribute_Code_Address |
5302 Attribute_Definite |
5303 Attribute_Null_Parameter |
5304 Attribute_Passed_By_Reference |
5305 Attribute_Pool_Address
=>
5308 -- The following attributes are also handled by the back end, but return
5309 -- a universal integer result, so may need a conversion for checking
5310 -- that the result is in range.
5312 when Attribute_Aft |
5313 Attribute_Max_Alignment_For_Allocation |
5314 Attribute_Max_Size_In_Storage_Elements
=>
5315 Apply_Universal_Integer_Attribute_Checks
(N
);
5317 -- The following attributes should not appear at this stage, since they
5318 -- have already been handled by the analyzer (and properly rewritten
5319 -- with corresponding values or entities to represent the right values)
5321 when Attribute_Abort_Signal |
5322 Attribute_Address_Size |
5325 Attribute_Compiler_Version |
5326 Attribute_Default_Bit_Order |
5333 Attribute_Fast_Math |
5334 Attribute_Has_Access_Values |
5335 Attribute_Has_Discriminants |
5336 Attribute_Has_Tagged_Values |
5338 Attribute_Machine_Emax |
5339 Attribute_Machine_Emin |
5340 Attribute_Machine_Mantissa |
5341 Attribute_Machine_Overflows |
5342 Attribute_Machine_Radix |
5343 Attribute_Machine_Rounds |
5344 Attribute_Maximum_Alignment |
5345 Attribute_Model_Emin |
5346 Attribute_Model_Epsilon |
5347 Attribute_Model_Mantissa |
5348 Attribute_Model_Small |
5350 Attribute_Partition_ID |
5352 Attribute_Safe_Emax |
5353 Attribute_Safe_First |
5354 Attribute_Safe_Large |
5355 Attribute_Safe_Last |
5356 Attribute_Safe_Small |
5358 Attribute_Signed_Zeros |
5360 Attribute_Storage_Unit |
5361 Attribute_Stub_Type |
5362 Attribute_Target_Name |
5363 Attribute_Type_Class |
5364 Attribute_Type_Key |
5365 Attribute_Unconstrained_Array |
5366 Attribute_Universal_Literal_String |
5367 Attribute_Wchar_T_Size |
5368 Attribute_Word_Size
=>
5370 raise Program_Error
;
5372 -- The Asm_Input and Asm_Output attributes are not expanded at this
5373 -- stage, but will be eliminated in the expansion of the Asm call, see
5374 -- Exp_Intr for details. So the back end will never see these either.
5376 when Attribute_Asm_Input |
5377 Attribute_Asm_Output
=>
5384 when RE_Not_Available
=>
5386 end Expand_N_Attribute_Reference
;
5388 ----------------------
5389 -- Expand_Pred_Succ --
5390 ----------------------
5392 -- For typ'Pred (exp), we generate the check
5394 -- [constraint_error when exp = typ'Base'First]
5396 -- Similarly, for typ'Succ (exp), we generate the check
5398 -- [constraint_error when exp = typ'Base'Last]
5400 -- These checks are not generated for modular types, since the proper
5401 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
5403 procedure Expand_Pred_Succ
(N
: Node_Id
) is
5404 Loc
: constant Source_Ptr
:= Sloc
(N
);
5408 if Attribute_Name
(N
) = Name_Pred
then
5415 Make_Raise_Constraint_Error
(Loc
,
5419 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
5421 Make_Attribute_Reference
(Loc
,
5423 New_Reference_To
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
5424 Attribute_Name
=> Cnam
)),
5425 Reason
=> CE_Overflow_Check_Failed
));
5426 end Expand_Pred_Succ
;
5432 procedure Find_Fat_Info
5434 Fat_Type
: out Entity_Id
;
5435 Fat_Pkg
: out RE_Id
)
5437 Btyp
: constant Entity_Id
:= Base_Type
(T
);
5438 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
5439 Digs
: constant Nat
:= UI_To_Int
(Digits_Value
(Btyp
));
5442 -- If the base type is VAX float, then get appropriate VAX float type
5444 if Vax_Float
(Btyp
) then
5447 Fat_Type
:= RTE
(RE_Fat_VAX_F
);
5448 Fat_Pkg
:= RE_Attr_VAX_F_Float
;
5451 Fat_Type
:= RTE
(RE_Fat_VAX_D
);
5452 Fat_Pkg
:= RE_Attr_VAX_D_Float
;
5455 Fat_Type
:= RTE
(RE_Fat_VAX_G
);
5456 Fat_Pkg
:= RE_Attr_VAX_G_Float
;
5459 raise Program_Error
;
5462 -- If root type is VAX float, this is the case where the library has
5463 -- been recompiled in VAX float mode, and we have an IEEE float type.
5464 -- This is when we use the special IEEE Fat packages.
5466 elsif Vax_Float
(Rtyp
) then
5469 Fat_Type
:= RTE
(RE_Fat_IEEE_Short
);
5470 Fat_Pkg
:= RE_Attr_IEEE_Short
;
5473 Fat_Type
:= RTE
(RE_Fat_IEEE_Long
);
5474 Fat_Pkg
:= RE_Attr_IEEE_Long
;
5477 raise Program_Error
;
5480 -- If neither the base type nor the root type is VAX_Float then VAX
5481 -- float is out of the picture, and we can just use the root type.
5486 if Fat_Type
= Standard_Short_Float
then
5487 Fat_Pkg
:= RE_Attr_Short_Float
;
5489 elsif Fat_Type
= Standard_Float
then
5490 Fat_Pkg
:= RE_Attr_Float
;
5492 elsif Fat_Type
= Standard_Long_Float
then
5493 Fat_Pkg
:= RE_Attr_Long_Float
;
5495 elsif Fat_Type
= Standard_Long_Long_Float
then
5496 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
5498 -- Universal real (which is its own root type) is treated as being
5499 -- equivalent to Standard.Long_Long_Float, since it is defined to
5500 -- have the same precision as the longest Float type.
5502 elsif Fat_Type
= Universal_Real
then
5503 Fat_Type
:= Standard_Long_Long_Float
;
5504 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
5507 raise Program_Error
;
5512 ----------------------------
5513 -- Find_Stream_Subprogram --
5514 ----------------------------
5516 function Find_Stream_Subprogram
5518 Nam
: TSS_Name_Type
) return Entity_Id
5520 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
5521 Ent
: constant Entity_Id
:= TSS
(Typ
, Nam
);
5524 if Present
(Ent
) then
5528 -- Stream attributes for strings are expanded into library calls. The
5529 -- following checks are disabled when the run-time is not available or
5530 -- when compiling predefined types due to bootstrap issues. As a result,
5531 -- the compiler will generate in-place stream routines for string types
5532 -- that appear in GNAT's library, but will generate calls via rtsfind
5533 -- to library routines for user code.
5535 -- ??? For now, disable this code for JVM, since this generates a
5536 -- VerifyError exception at run time on e.g. c330001.
5538 -- This is disabled for AAMP, to avoid creating dependences on files not
5539 -- supported in the AAMP library (such as s-fileio.adb).
5541 if VM_Target
/= JVM_Target
5542 and then not AAMP_On_Target
5544 not Is_Predefined_File_Name
(Unit_File_Name
(Current_Sem_Unit
))
5546 -- String as defined in package Ada
5548 if Base_Typ
= Standard_String
then
5549 if Restriction_Active
(No_Stream_Optimizations
) then
5550 if Nam
= TSS_Stream_Input
then
5551 return RTE
(RE_String_Input
);
5553 elsif Nam
= TSS_Stream_Output
then
5554 return RTE
(RE_String_Output
);
5556 elsif Nam
= TSS_Stream_Read
then
5557 return RTE
(RE_String_Read
);
5559 else pragma Assert
(Nam
= TSS_Stream_Write
);
5560 return RTE
(RE_String_Write
);
5564 if Nam
= TSS_Stream_Input
then
5565 return RTE
(RE_String_Input_Blk_IO
);
5567 elsif Nam
= TSS_Stream_Output
then
5568 return RTE
(RE_String_Output_Blk_IO
);
5570 elsif Nam
= TSS_Stream_Read
then
5571 return RTE
(RE_String_Read_Blk_IO
);
5573 else pragma Assert
(Nam
= TSS_Stream_Write
);
5574 return RTE
(RE_String_Write_Blk_IO
);
5578 -- Wide_String as defined in package Ada
5580 elsif Base_Typ
= Standard_Wide_String
then
5581 if Restriction_Active
(No_Stream_Optimizations
) then
5582 if Nam
= TSS_Stream_Input
then
5583 return RTE
(RE_Wide_String_Input
);
5585 elsif Nam
= TSS_Stream_Output
then
5586 return RTE
(RE_Wide_String_Output
);
5588 elsif Nam
= TSS_Stream_Read
then
5589 return RTE
(RE_Wide_String_Read
);
5591 else pragma Assert
(Nam
= TSS_Stream_Write
);
5592 return RTE
(RE_Wide_String_Write
);
5596 if Nam
= TSS_Stream_Input
then
5597 return RTE
(RE_Wide_String_Input_Blk_IO
);
5599 elsif Nam
= TSS_Stream_Output
then
5600 return RTE
(RE_Wide_String_Output_Blk_IO
);
5602 elsif Nam
= TSS_Stream_Read
then
5603 return RTE
(RE_Wide_String_Read_Blk_IO
);
5605 else pragma Assert
(Nam
= TSS_Stream_Write
);
5606 return RTE
(RE_Wide_String_Write_Blk_IO
);
5610 -- Wide_Wide_String as defined in package Ada
5612 elsif Base_Typ
= Standard_Wide_Wide_String
then
5613 if Restriction_Active
(No_Stream_Optimizations
) then
5614 if Nam
= TSS_Stream_Input
then
5615 return RTE
(RE_Wide_Wide_String_Input
);
5617 elsif Nam
= TSS_Stream_Output
then
5618 return RTE
(RE_Wide_Wide_String_Output
);
5620 elsif Nam
= TSS_Stream_Read
then
5621 return RTE
(RE_Wide_Wide_String_Read
);
5623 else pragma Assert
(Nam
= TSS_Stream_Write
);
5624 return RTE
(RE_Wide_Wide_String_Write
);
5628 if Nam
= TSS_Stream_Input
then
5629 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
5631 elsif Nam
= TSS_Stream_Output
then
5632 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
5634 elsif Nam
= TSS_Stream_Read
then
5635 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
5637 else pragma Assert
(Nam
= TSS_Stream_Write
);
5638 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
5644 if Is_Tagged_Type
(Typ
)
5645 and then Is_Derived_Type
(Typ
)
5647 return Find_Prim_Op
(Typ
, Nam
);
5649 return Find_Inherited_TSS
(Typ
, Nam
);
5651 end Find_Stream_Subprogram
;
5657 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
5661 BT
:= Base_Type
(T
);
5663 if Is_Private_Type
(BT
)
5664 and then Present
(Full_View
(BT
))
5666 BT
:= Full_View
(BT
);
5672 -----------------------
5673 -- Get_Index_Subtype --
5674 -----------------------
5676 function Get_Index_Subtype
(N
: Node_Id
) return Node_Id
is
5677 P_Type
: Entity_Id
:= Etype
(Prefix
(N
));
5682 if Is_Access_Type
(P_Type
) then
5683 P_Type
:= Designated_Type
(P_Type
);
5686 if No
(Expressions
(N
)) then
5689 J
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
5692 Indx
:= First_Index
(P_Type
);
5698 return Etype
(Indx
);
5699 end Get_Index_Subtype
;
5701 -------------------------------
5702 -- Get_Stream_Convert_Pragma --
5703 -------------------------------
5705 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
5710 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
5711 -- that a stream convert pragma for a tagged type is not inherited from
5712 -- its parent. Probably what is wrong here is that it is basically
5713 -- incorrect to consider a stream convert pragma to be a representation
5714 -- pragma at all ???
5716 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
5717 while Present
(N
) loop
5718 if Nkind
(N
) = N_Pragma
5719 and then Pragma_Name
(N
) = Name_Stream_Convert
5721 -- For tagged types this pragma is not inherited, so we
5722 -- must verify that it is defined for the given type and
5726 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
5728 if not Is_Tagged_Type
(T
)
5730 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
5740 end Get_Stream_Convert_Pragma
;
5742 ---------------------------------
5743 -- Is_Constrained_Packed_Array --
5744 ---------------------------------
5746 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
5747 Arr
: Entity_Id
:= Typ
;
5750 if Is_Access_Type
(Arr
) then
5751 Arr
:= Designated_Type
(Arr
);
5754 return Is_Array_Type
(Arr
)
5755 and then Is_Constrained
(Arr
)
5756 and then Present
(Packed_Array_Type
(Arr
));
5757 end Is_Constrained_Packed_Array
;
5759 ----------------------------------------
5760 -- Is_Inline_Floating_Point_Attribute --
5761 ----------------------------------------
5763 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
5764 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
5767 if Nkind
(Parent
(N
)) /= N_Type_Conversion
5768 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
5773 -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
5774 -- required back end support has not been implemented yet ???
5776 return Id
= Attribute_Truncation
;
5777 end Is_Inline_Floating_Point_Attribute
;