1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Accessibility
; use Accessibility
;
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Debug
; use Debug
;
31 with Einfo
; use Einfo
;
32 with Einfo
.Entities
; use Einfo
.Entities
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Elists
; use Elists
;
35 with Exp_Atag
; use Exp_Atag
;
36 with Exp_Ch3
; use Exp_Ch3
;
37 with Exp_Ch6
; use Exp_Ch6
;
38 with Exp_Ch9
; use Exp_Ch9
;
39 with Exp_Dist
; use Exp_Dist
;
40 with Exp_Imgv
; use Exp_Imgv
;
41 with Exp_Pakd
; use Exp_Pakd
;
42 with Exp_Strm
; use Exp_Strm
;
44 with Exp_Tss
; use Exp_Tss
;
45 with Exp_Util
; use Exp_Util
;
46 with Expander
; use Expander
;
47 with Freeze
; use Freeze
;
48 with Gnatvsn
; use Gnatvsn
;
49 with Itypes
; use Itypes
;
51 with Namet
; use Namet
;
52 with Nmake
; use Nmake
;
53 with Nlists
; use Nlists
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch6
; use Sem_Ch6
;
61 with Sem_Ch7
; use Sem_Ch7
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Eval
; use Sem_Eval
;
64 with Sem_Res
; use Sem_Res
;
65 with Sem_Util
; use Sem_Util
;
66 with Sinfo
; use Sinfo
;
67 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
68 with Sinfo
.Utils
; use Sinfo
.Utils
;
69 with Snames
; use Snames
;
70 with Stand
; use Stand
;
71 with Stringt
; use Stringt
;
72 with Strub
; use Strub
;
73 with Tbuild
; use Tbuild
;
74 with Ttypes
; use Ttypes
;
75 with Uintp
; use Uintp
;
76 with Uname
; use Uname
;
77 with Urealp
; use Urealp
;
78 with Validsw
; use Validsw
;
82 package body Exp_Attr
is
84 package Cached_Streaming_Ops
is
86 Map_Size
: constant := 63;
87 subtype Header_Num
is Integer range 0 .. Map_Size
- 1;
89 function Streaming_Op_Hash
(Id
: Entity_Id
) return Header_Num
is
90 (Header_Num
(Id
mod Map_Size
));
92 -- Cache used to avoid building duplicate subprograms for a single
93 -- type/streaming-attribute pair.
95 package Read_Map
is new GNAT
.HTable
.Simple_HTable
96 (Header_Num
=> Header_Num
,
100 Hash
=> Streaming_Op_Hash
,
103 package Write_Map
is new GNAT
.HTable
.Simple_HTable
104 (Header_Num
=> Header_Num
,
106 Element
=> Entity_Id
,
108 Hash
=> Streaming_Op_Hash
,
111 package Input_Map
is new GNAT
.HTable
.Simple_HTable
112 (Header_Num
=> Header_Num
,
114 Element
=> Entity_Id
,
116 Hash
=> Streaming_Op_Hash
,
119 package Output_Map
is new GNAT
.HTable
.Simple_HTable
120 (Header_Num
=> Header_Num
,
122 Element
=> Entity_Id
,
124 Hash
=> Streaming_Op_Hash
,
127 end Cached_Streaming_Ops
;
129 -----------------------
130 -- Local Subprograms --
131 -----------------------
133 function Build_Array_VS_Func
135 Formal_Typ
: Entity_Id
;
136 Array_Typ
: Entity_Id
) return Entity_Id
;
137 -- Validate the components of an array type by means of a function. Return
138 -- the entity of the validation function. The parameters are as follows:
140 -- * Attr - the 'Valid_Scalars attribute for which the function is
143 -- * Formal_Typ - the type of the generated function's only formal
146 -- * Array_Typ - the array type whose components are to be validated
148 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
;
149 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
151 function Build_Record_VS_Func
153 Formal_Typ
: Entity_Id
;
154 Rec_Typ
: Entity_Id
) return Entity_Id
;
155 -- Validate the components, discriminants, and variants of a record type by
156 -- means of a function. Return the entity of the validation function. The
157 -- parameters are as follows:
159 -- * Attr - the 'Valid_Scalars attribute for which the function is
162 -- * Formal_Typ - the type of the generated function's only formal
165 -- * Rec_Typ - the record type whose internals are to be validated
167 procedure Compile_Stream_Body_In_Scope
171 -- The body for a stream subprogram may be generated outside of the scope
172 -- of the type. If the type is fully private, it may depend on the full
173 -- view of other types (e.g. indexes) that are currently private as well.
174 -- We install the declarations of the package in which the type is declared
175 -- before compiling the body in what is its proper environment. The Check
176 -- parameter indicates if checks are to be suppressed for the stream body.
177 -- We suppress checks for array/record reads, since the rule is that these
178 -- are like assignments, out of range values due to uninitialized storage,
179 -- or other invalid values do NOT cause a Constraint_Error to be raised.
180 -- If we are within an instance body all visibility has been established
181 -- already and there is no need to install the package.
183 -- This mechanism is now extended to the component types of the array type,
184 -- when the component type is not in scope and is private, to handle
185 -- properly the case when the full view has defaulted discriminants.
187 -- This special processing is ultimately caused by the fact that the
188 -- compiler lacks a well-defined phase when full views are visible
189 -- everywhere. Having such a separate pass would remove much of the
190 -- special-case code that shuffles partial and full views in the middle
191 -- of semantic analysis and expansion.
193 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean;
195 -- In most cases, references to unavailable streaming attributes
196 -- are rejected at compile time. In some obscure cases involving
197 -- generics and formal derived types, the problem is dealt with at runtime.
199 procedure Expand_Access_To_Protected_Op
203 -- An attribute reference to a protected subprogram is transformed into
204 -- a pair of pointers: one to the object, and one to the operations.
205 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
207 procedure Expand_Fpt_Attribute
212 -- This procedure expands a call to a floating-point attribute function.
213 -- N is the attribute reference node, and Args is a list of arguments to
214 -- be passed to the function call. Pkg identifies the package containing
215 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
216 -- have already been converted to the floating-point type for which Pkg was
217 -- instantiated. The Nam argument is the relevant attribute processing
218 -- routine to be called. This is the same as the attribute name.
220 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
);
221 -- This procedure expands a call to a floating-point attribute function
222 -- that takes a single floating-point argument. The function to be called
223 -- is always the same as the attribute name.
225 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
);
226 -- This procedure expands a call to a floating-point attribute function
227 -- that takes one floating-point argument and one integer argument. The
228 -- function to be called is always the same as the attribute name.
230 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
);
231 -- This procedure expands a call to a floating-point attribute function
232 -- that takes two floating-point arguments. The function to be called
233 -- is always the same as the attribute name.
235 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
);
236 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
237 -- loop may be converted into a conditional block. See body for details.
239 procedure Expand_Min_Max_Attribute
(N
: Node_Id
);
240 -- Handle the expansion of attributes 'Max and 'Min, including expanding
241 -- then out if we are in Modify_Tree_For_C mode.
243 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
);
244 -- Handles expansion of Pred or Succ attributes for case of non-real
245 -- operand with overflow checking required.
247 procedure Expand_Update_Attribute
(N
: Node_Id
);
248 -- Handle the expansion of attribute Update
250 procedure Find_Fat_Info
252 Fat_Type
: out Entity_Id
;
253 Fat_Pkg
: out RE_Id
);
254 -- Given a floating-point type T, identifies the package containing the
255 -- attributes for this type (returned in Fat_Pkg), and the corresponding
256 -- type for which this package was instantiated from Fat_Gen. Error if T
257 -- is not a floating-point type.
259 function Find_Stream_Subprogram
262 Attr_Ref
: Node_Id
) return Entity_Id
;
263 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
264 -- types, the corresponding primitive operation is looked up, else the
265 -- appropriate TSS from the type itself, or from its closest ancestor
266 -- defining it, is returned. In both cases, inheritance of representation
267 -- aspects is thus taken into account. Attr_Ref is used to identify the
268 -- point from which the function result will be referenced.
270 function Full_Base
(T
: Entity_Id
) return Entity_Id
;
271 -- The stream functions need to examine the underlying representation of
272 -- composite types. In some cases T may be non-private but its base type
273 -- is, in which case the function returns the corresponding full view.
275 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
;
276 -- Given a type, find a corresponding stream convert pragma that applies to
277 -- the implementation base type of this type (Typ). If found, return the
278 -- pragma node, otherwise return Empty if no pragma is found.
280 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean;
281 -- Utility for array attributes, returns true on packed constrained
282 -- arrays, and on access to same.
284 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean;
285 -- Returns true iff the given node refers to an attribute call that
286 -- can be expanded directly by the back end and does not need front end
287 -- expansion. Typically used for rounding and truncation attributes that
288 -- appear directly inside a conversion to integer.
290 -------------------------
291 -- Build_Array_VS_Func --
292 -------------------------
294 function Build_Array_VS_Func
296 Formal_Typ
: Entity_Id
;
297 Array_Typ
: Entity_Id
) return Entity_Id
299 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
300 Comp_Typ
: constant Entity_Id
:=
301 Validated_View
(Component_Type
(Array_Typ
));
303 function Validate_Component
305 Indexes
: List_Id
) return Node_Id
;
306 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
307 -- the entity of the validation parameter. Return the check associated
308 -- with the component.
310 function Validate_Dimension
313 Indexes
: List_Id
) return Node_Id
;
314 -- Process dimension Dim of the array type. Obj_Id denotes the entity
315 -- of the validation parameter. Indexes is a list where each dimension
316 -- deposits its loop variable, which will later identify a component.
317 -- Return the loop associated with the current dimension.
319 ------------------------
320 -- Validate_Component --
321 ------------------------
323 function Validate_Component
325 Indexes
: List_Id
) return Node_Id
330 if Is_Scalar_Type
(Comp_Typ
) then
331 Attr_Nam
:= Name_Valid
;
333 Attr_Nam
:= Name_Valid_Scalars
;
337 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
342 Make_If_Statement
(Loc
,
346 Make_Attribute_Reference
(Loc
,
348 Make_Indexed_Component
(Loc
,
350 Unchecked_Convert_To
(Array_Typ
,
351 New_Occurrence_Of
(Obj_Id
, Loc
)),
352 Expressions
=> Indexes
),
353 Attribute_Name
=> Attr_Nam
)),
355 Then_Statements
=> New_List
(
356 Make_Simple_Return_Statement
(Loc
,
357 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
))));
358 end Validate_Component
;
360 ------------------------
361 -- Validate_Dimension --
362 ------------------------
364 function Validate_Dimension
367 Indexes
: List_Id
) return Node_Id
372 -- Validate the component once all dimensions have produced their
375 if Dim
> Number_Dimensions
(Array_Typ
) then
376 return Validate_Component
(Obj_Id
, Indexes
);
378 -- Process the current dimension
382 Make_Defining_Identifier
(Loc
, New_External_Name
('J', Dim
));
384 Append_To
(Indexes
, New_Occurrence_Of
(Index
, Loc
));
387 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
388 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
389 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
397 Make_Implicit_Loop_Statement
(Attr
,
400 Make_Iteration_Scheme
(Loc
,
401 Loop_Parameter_Specification
=>
402 Make_Loop_Parameter_Specification
(Loc
,
403 Defining_Identifier
=> Index
,
404 Discrete_Subtype_Definition
=>
405 Make_Attribute_Reference
(Loc
,
407 Unchecked_Convert_To
(Array_Typ
,
408 New_Occurrence_Of
(Obj_Id
, Loc
)),
409 Attribute_Name
=> Name_Range
,
410 Expressions
=> New_List
(
411 Make_Integer_Literal
(Loc
, Dim
))))),
412 Statements
=> New_List
(
413 Validate_Dimension
(Obj_Id
, Dim
+ 1, Indexes
)));
415 end Validate_Dimension
;
419 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
420 Indexes
: constant List_Id
:= New_List
;
421 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'A');
424 -- Start of processing for Build_Array_VS_Func
427 Stmts
:= New_List
(Validate_Dimension
(Obj_Id
, 1, Indexes
));
433 Make_Simple_Return_Statement
(Loc
,
434 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
437 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
442 Mutate_Ekind
(Func_Id
, E_Function
);
443 Set_Is_Internal
(Func_Id
);
444 Set_Is_Pure
(Func_Id
);
446 if not Debug_Generated_Code
then
447 Set_Debug_Info_Off
(Func_Id
);
451 Make_Subprogram_Body
(Loc
,
453 Make_Function_Specification
(Loc
,
454 Defining_Unit_Name
=> Func_Id
,
455 Parameter_Specifications
=> New_List
(
456 Make_Parameter_Specification
(Loc
,
457 Defining_Identifier
=> Obj_Id
,
458 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
460 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
461 Declarations
=> New_List
,
462 Handled_Statement_Sequence
=>
463 Make_Handled_Sequence_Of_Statements
(Loc
,
464 Statements
=> Stmts
)));
467 end Build_Array_VS_Func
;
469 ---------------------------------
470 -- Build_Disp_Get_Task_Id_Call --
471 ---------------------------------
473 function Build_Disp_Get_Task_Id_Call
(Actual
: Node_Id
) return Node_Id
is
474 Loc
: constant Source_Ptr
:= Sloc
(Actual
);
475 Typ
: constant Entity_Id
:= Etype
(Actual
);
476 Subp
: constant Entity_Id
:= Find_Prim_Op
(Typ
, Name_uDisp_Get_Task_Id
);
480 -- _Disp_Get_Task_Id (Actual)
483 Make_Function_Call
(Loc
,
484 Name
=> New_Occurrence_Of
(Subp
, Loc
),
485 Parameter_Associations
=> New_List
(Actual
));
486 end Build_Disp_Get_Task_Id_Call
;
488 --------------------------
489 -- Build_Record_VS_Func --
490 --------------------------
492 function Build_Record_VS_Func
494 Formal_Typ
: Entity_Id
;
495 Rec_Typ
: Entity_Id
) return Entity_Id
497 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
498 -- It generates code only when there are components, discriminants,
499 -- or variant parts to validate.
501 -- NOTE: The routines within Build_Record_VS_Func are intentionally
502 -- unnested to avoid deep indentation of code.
504 Loc
: constant Source_Ptr
:= Sloc
(Attr
);
506 procedure Validate_Component_List
509 Stmts
: in out List_Id
);
510 -- Process all components and variant parts of component list Comp_List.
511 -- Obj_Id denotes the entity of the validation parameter. All new code
512 -- is added to list Stmts.
514 procedure Validate_Field
517 Cond
: in out Node_Id
);
518 -- Process component declaration or discriminant specification Field.
519 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
520 -- an "or else" conditional expression which contains the new code (if
523 procedure Validate_Fields
526 Stmts
: in out List_Id
);
527 -- Process component declarations or discriminant specifications in list
528 -- Fields. Obj_Id denotes the entity of the validation parameter. All
529 -- new code is added to list Stmts.
531 procedure Validate_Variant
534 Alts
: in out List_Id
);
535 -- Process variant Var. Obj_Id denotes the entity of the validation
536 -- parameter. Alts denotes a list of case statement alternatives which
537 -- contains the new code (if any).
539 procedure Validate_Variant_Part
542 Stmts
: in out List_Id
);
543 -- Process variant part Var_Part. Obj_Id denotes the entity of the
544 -- validation parameter. All new code is added to list Stmts.
546 -----------------------------
547 -- Validate_Component_List --
548 -----------------------------
550 procedure Validate_Component_List
553 Stmts
: in out List_Id
)
555 Var_Part
: constant Node_Id
:= Variant_Part
(Comp_List
);
558 -- Validate all components
562 Fields
=> Component_Items
(Comp_List
),
565 -- Validate the variant part
567 if Present
(Var_Part
) then
568 Validate_Variant_Part
570 Var_Part
=> Var_Part
,
573 end Validate_Component_List
;
579 procedure Validate_Field
582 Cond
: in out Node_Id
)
584 Field_Id
: constant Entity_Id
:= Defining_Entity
(Field
);
585 Field_Nam
: constant Name_Id
:= Chars
(Field_Id
);
586 Field_Typ
: constant Entity_Id
:= Validated_View
(Etype
(Field_Id
));
590 -- Do not process internally-generated fields. Note that checking for
591 -- Comes_From_Source is not correct because this will eliminate the
592 -- components within the corresponding record of a protected type.
594 if Field_Nam
in Name_uObject | Name_uParent | Name_uTag
then
597 -- Do not process fields without any scalar components
599 elsif not Scalar_Part_Present
(Field_Typ
) then
602 -- Otherwise the field needs to be validated. Use Make_Identifier
603 -- rather than New_Occurrence_Of to identify the field because the
604 -- wrong entity may be picked up when private types are involved.
607 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
610 if Is_Scalar_Type
(Field_Typ
) then
611 Attr_Nam
:= Name_Valid
;
613 Attr_Nam
:= Name_Valid_Scalars
;
616 Evolve_Or_Else
(Cond
,
619 Make_Attribute_Reference
(Loc
,
621 Make_Selected_Component
(Loc
,
623 Unchecked_Convert_To
(Rec_Typ
,
624 New_Occurrence_Of
(Obj_Id
, Loc
)),
625 Selector_Name
=> Make_Identifier
(Loc
, Field_Nam
)),
626 Attribute_Name
=> Attr_Nam
)));
630 ---------------------
631 -- Validate_Fields --
632 ---------------------
634 procedure Validate_Fields
637 Stmts
: in out List_Id
)
643 -- Assume that none of the fields are eligible for verification
647 -- Validate all fields
649 Field
:= First_Non_Pragma
(Fields
);
650 while Present
(Field
) loop
656 Next_Non_Pragma
(Field
);
660 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
661 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
666 if Present
(Cond
) then
667 Append_New_To
(Stmts
,
668 Make_Implicit_If_Statement
(Attr
,
670 Then_Statements
=> New_List
(
671 Make_Simple_Return_Statement
(Loc
,
672 Expression
=> New_Occurrence_Of
(Standard_False
, Loc
)))));
676 ----------------------
677 -- Validate_Variant --
678 ----------------------
680 procedure Validate_Variant
683 Alts
: in out List_Id
)
688 -- Assume that none of the components and variants are eligible for
693 -- Validate components
695 Validate_Component_List
697 Comp_List
=> Component_List
(Var
),
700 -- Generate a null statement in case none of the components were
701 -- verified because this will otherwise eliminate an alternative
702 -- from the variant case statement and render the generated code
706 Append_New_To
(Stmts
, Make_Null_Statement
(Loc
));
710 -- when Discrete_Choices =>
714 Make_Case_Statement_Alternative
(Loc
,
716 New_Copy_List_Tree
(Discrete_Choices
(Var
)),
717 Statements
=> Stmts
));
718 end Validate_Variant
;
720 ---------------------------
721 -- Validate_Variant_Part --
722 ---------------------------
724 procedure Validate_Variant_Part
727 Stmts
: in out List_Id
)
729 Vars
: constant List_Id
:= Variants
(Var_Part
);
734 -- Assume that none of the variants are eligible for verification
740 Var
:= First_Non_Pragma
(Vars
);
741 while Present
(Var
) loop
747 Next_Non_Pragma
(Var
);
750 -- Even though individual variants may lack eligible components, the
751 -- alternatives must still be generated.
753 pragma Assert
(Present
(Alts
));
756 -- case Rec_Typ (Obj_Id).Discriminant is
757 -- when Discrete_Choices_1 =>
759 -- when Discrete_Choices_N =>
763 Append_New_To
(Stmts
,
764 Make_Case_Statement
(Loc
,
766 Make_Selected_Component
(Loc
,
768 Unchecked_Convert_To
(Rec_Typ
,
769 New_Occurrence_Of
(Obj_Id
, Loc
)),
770 Selector_Name
=> New_Copy_Tree
(Name
(Var_Part
))),
771 Alternatives
=> Alts
));
772 end Validate_Variant_Part
;
776 Func_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
777 Obj_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'R');
785 -- Start of processing for Build_Record_VS_Func
788 Typ
:= Validated_View
(Rec_Typ
);
790 -- Use the root type when dealing with a class-wide type
792 if Is_Class_Wide_Type
(Typ
) then
793 Typ
:= Validated_View
(Root_Type
(Typ
));
796 Typ_Decl
:= Declaration_Node
(Typ
);
797 Typ_Def
:= Type_Definition
(Typ_Decl
);
799 -- The components of a derived type are located in the extension part
801 if Nkind
(Typ_Def
) = N_Derived_Type_Definition
then
802 Typ_Ext
:= Record_Extension_Part
(Typ_Def
);
804 if Present
(Typ_Ext
) then
805 Comps
:= Component_List
(Typ_Ext
);
810 -- Otherwise the components are available in the definition
813 Comps
:= Component_List
(Typ_Def
);
816 -- The code generated by this routine is as follows:
818 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
820 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
821 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
826 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
827 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
832 -- case Discriminant_1 is
834 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
835 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
840 -- case Discriminant_N is
849 -- Assume that the record type lacks eligible components, discriminants,
850 -- and variant parts.
854 -- Validate the discriminants
856 if not Is_Unchecked_Union
(Rec_Typ
) then
859 Fields
=> Discriminant_Specifications
(Typ_Decl
),
863 -- Validate the components and variant parts
865 Validate_Component_List
873 Append_New_To
(Stmts
,
874 Make_Simple_Return_Statement
(Loc
,
875 Expression
=> New_Occurrence_Of
(Standard_True
, Loc
)));
878 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
883 Mutate_Ekind
(Func_Id
, E_Function
);
884 Set_Is_Internal
(Func_Id
);
885 Set_Is_Pure
(Func_Id
);
887 if not Debug_Generated_Code
then
888 Set_Debug_Info_Off
(Func_Id
);
892 Make_Subprogram_Body
(Loc
,
894 Make_Function_Specification
(Loc
,
895 Defining_Unit_Name
=> Func_Id
,
896 Parameter_Specifications
=> New_List
(
897 Make_Parameter_Specification
(Loc
,
898 Defining_Identifier
=> Obj_Id
,
899 Parameter_Type
=> New_Occurrence_Of
(Formal_Typ
, Loc
))),
901 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
902 Declarations
=> New_List
,
903 Handled_Statement_Sequence
=>
904 Make_Handled_Sequence_Of_Statements
(Loc
,
905 Statements
=> Stmts
)),
906 Suppress
=> Discriminant_Check
);
909 end Build_Record_VS_Func
;
911 ----------------------------------
912 -- Compile_Stream_Body_In_Scope --
913 ----------------------------------
915 procedure Compile_Stream_Body_In_Scope
920 C_Type
: constant Entity_Id
:= Base_Type
(Component_Type
(Arr
));
921 Curr
: constant Entity_Id
:= Current_Scope
;
922 Install
: Boolean := False;
923 Scop
: Entity_Id
:= Scope
(Arr
);
927 and then not In_Open_Scopes
(Scop
)
928 and then Ekind
(Scop
) = E_Package
933 -- The component type may be private, in which case we install its
934 -- full view to compile the subprogram.
936 -- The component type may be private, in which case we install its
937 -- full view to compile the subprogram. We do not do this if the
938 -- type has a Stream_Convert pragma, which indicates that there are
939 -- special stream-processing operations for that type (for example
940 -- Unbounded_String and its wide varieties).
942 -- We don't install the package either if array type and element
943 -- type come from the same package, and the original array type is
944 -- private, because in this case the underlying type Arr is
945 -- itself a full view, which carries the full view of the component.
947 Scop
:= Scope
(C_Type
);
949 if Is_Private_Type
(C_Type
)
950 and then Present
(Full_View
(C_Type
))
951 and then not In_Open_Scopes
(Scop
)
952 and then Ekind
(Scop
) = E_Package
953 and then No
(Get_Stream_Convert_Pragma
(C_Type
))
955 if Scope
(Arr
) = Scope
(C_Type
)
956 and then Is_Private_Type
(Etype
(Prefix
(N
)))
957 and then Full_View
(Etype
(Prefix
(N
))) = Arr
967 -- If we are within an instance body, then all visibility has been
968 -- established already and there is no need to install the package.
970 if Install
and then not In_Instance_Body
then
972 Install_Visible_Declarations
(Scop
);
973 Install_Private_Declarations
(Scop
);
975 -- The entities in the package are now visible, but the generated
976 -- stream entity must appear in the current scope (usually an
977 -- enclosing stream function) so that itypes all have their proper
985 Insert_Action
(N
, Decl
);
989 -- Remove extra copy of current scope, and package itself
992 End_Package_Scope
(Scop
);
994 end Compile_Stream_Body_In_Scope
;
996 -----------------------------------
997 -- Default_Streaming_Unavailable --
998 -----------------------------------
1000 function Default_Streaming_Unavailable
(Typ
: Entity_Id
) return Boolean is
1001 Btyp
: constant Entity_Id
:= Implementation_Base_Type
(Typ
);
1003 if Is_Immutably_Limited_Type
(Btyp
)
1004 and then not Is_Tagged_Type
(Btyp
)
1005 and then not (Ekind
(Btyp
) = E_Record_Type
1006 and then Present
(Corresponding_Concurrent_Type
(Btyp
)))
1008 pragma Assert
(In_Instance_Body
);
1012 end Default_Streaming_Unavailable
;
1014 -----------------------------------
1015 -- Expand_Access_To_Protected_Op --
1016 -----------------------------------
1018 procedure Expand_Access_To_Protected_Op
1023 -- The value of the attribute_reference is a record containing two
1024 -- fields: an access to the protected object, and an access to the
1025 -- subprogram itself. The prefix is an identifier or a selected
1028 function Has_By_Protected_Procedure_Prefixed_View
return Boolean;
1029 -- Determine whether Pref denotes the prefixed class-wide interface
1030 -- view of a procedure with synchronization kind By_Protected_Procedure.
1032 ----------------------------------------------
1033 -- Has_By_Protected_Procedure_Prefixed_View --
1034 ----------------------------------------------
1036 function Has_By_Protected_Procedure_Prefixed_View
return Boolean is
1038 return Nkind
(Pref
) = N_Selected_Component
1039 and then Nkind
(Prefix
(Pref
)) in N_Has_Entity
1040 and then Present
(Entity
(Prefix
(Pref
)))
1041 and then Is_Class_Wide_Type
(Etype
(Entity
(Prefix
(Pref
))))
1042 and then (Is_Synchronized_Interface
(Etype
(Entity
(Prefix
(Pref
))))
1044 Is_Protected_Interface
(Etype
(Entity
(Prefix
(Pref
)))))
1045 and then Is_By_Protected_Procedure
(Entity
(Selector_Name
(Pref
)));
1046 end Has_By_Protected_Procedure_Prefixed_View
;
1050 Loc
: constant Source_Ptr
:= Sloc
(N
);
1052 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
1053 Sub
: Entity_Id
:= Empty
;
1055 E_T
: constant Entity_Id
:= Equivalent_Type
(Btyp
);
1056 Acc
: constant Entity_Id
:=
1057 Etype
(Next_Component
(First_Component
(E_T
)));
1061 -- Start of processing for Expand_Access_To_Protected_Op
1064 -- Within the body of the protected type, the prefix designates a local
1065 -- operation, and the object is the first parameter of the corresponding
1066 -- protected body of the current enclosing operation.
1068 if Is_Entity_Name
(Pref
) then
1069 -- All indirect calls are external calls, so must do locking and
1070 -- barrier reevaluation, even if the 'Access occurs within the
1071 -- protected body. Hence the call to External_Subprogram, as opposed
1072 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
1073 -- that indirect calls from within the same protected body will
1074 -- deadlock, as allowed by RM-9.5.1(8,15,17).
1076 Sub
:= New_Occurrence_Of
(External_Subprogram
(Entity
(Pref
)), Loc
);
1078 -- Don't traverse the scopes when the attribute occurs within an init
1079 -- proc, because we directly use the _init formal of the init proc in
1082 Curr
:= Current_Scope
;
1083 if not Is_Init_Proc
(Curr
) then
1084 pragma Assert
(In_Open_Scopes
(Scope
(Entity
(Pref
))));
1086 while Scope
(Curr
) /= Scope
(Entity
(Pref
)) loop
1087 Curr
:= Scope
(Curr
);
1091 -- In case of protected entries the first formal of its Protected_
1092 -- Body_Subprogram is the address of the object.
1094 if Ekind
(Curr
) = E_Entry
then
1098 (Protected_Body_Subprogram
(Curr
)), Loc
);
1100 -- If the current scope is an init proc, then use the address of the
1101 -- _init formal as the object reference.
1103 elsif Is_Init_Proc
(Curr
) then
1105 Make_Attribute_Reference
(Loc
,
1106 Prefix
=> New_Occurrence_Of
(First_Formal
(Curr
), Loc
),
1107 Attribute_Name
=> Name_Address
);
1109 -- In case of protected subprograms the first formal of its
1110 -- Protected_Body_Subprogram is the object and we get its address.
1114 Make_Attribute_Reference
(Loc
,
1118 (Protected_Body_Subprogram
(Curr
)), Loc
),
1119 Attribute_Name
=> Name_Address
);
1122 elsif Has_By_Protected_Procedure_Prefixed_View
then
1124 Make_Attribute_Reference
(Loc
,
1125 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1126 Attribute_Name
=> Name_Address
);
1128 -- Analyze the object address with expansion disabled. Required
1129 -- because its expansion would displace the pointer to the object,
1130 -- which is not correct at this stage since the object type is a
1131 -- class-wide interface type and we are dispatching a call to a
1132 -- thunk (which would erroneously displace the pointer again).
1134 Expander_Mode_Save_And_Set
(False);
1136 Set_Analyzed
(Obj_Ref
);
1137 Expander_Mode_Restore
;
1139 -- Case where the prefix is not an entity name. Find the
1140 -- version of the protected operation to be called from
1141 -- outside the protected object.
1146 (External_Subprogram
1147 (Entity
(Selector_Name
(Pref
))), Loc
);
1150 Make_Attribute_Reference
(Loc
,
1151 Prefix
=> Relocate_Node
(Prefix
(Pref
)),
1152 Attribute_Name
=> Name_Address
);
1155 if Has_By_Protected_Procedure_Prefixed_View
then
1157 Ctrl_Tag
: Node_Id
:= Duplicate_Subexpr
(Prefix
(Pref
));
1158 Prim_Addr
: Node_Id
;
1159 Subp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
1160 Typ
: constant Entity_Id
:=
1161 Etype
(Etype
(Entity
(Prefix
(Pref
))));
1163 -- The target subprogram is a thunk; retrieve its address from
1164 -- its secondary dispatch table slot.
1166 Build_Get_Prim_Op_Address
(Loc
,
1168 Tag_Node
=> Ctrl_Tag
,
1169 Position
=> DT_Position
(Subp
),
1170 New_Node
=> Prim_Addr
);
1172 -- Mark the access to the target subprogram as an access to the
1173 -- dispatch table and perform an unchecked type conversion to such
1174 -- access type. This is required to allow the backend to properly
1175 -- identify and handle the access to the dispatch table slot on
1176 -- targets where the dispatch table contains descriptors (instead
1179 Set_Is_Dispatch_Table_Entity
(Acc
);
1180 Sub_Ref
:= Unchecked_Convert_To
(Acc
, Prim_Addr
);
1184 Make_Aggregate
(Loc
,
1185 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1192 Make_Attribute_Reference
(Loc
,
1194 Attribute_Name
=> Name_Access
);
1196 -- We set the type of the access reference to the already generated
1197 -- access_to_subprogram type, and declare the reference analyzed,
1198 -- to prevent further expansion when the enclosing aggregate is
1201 Set_Etype
(Sub_Ref
, Acc
);
1202 Set_Analyzed
(Sub_Ref
);
1205 Make_Aggregate
(Loc
,
1206 Expressions
=> New_List
(Obj_Ref
, Sub_Ref
));
1208 -- Sub_Ref has been marked as analyzed, but we still need to make
1209 -- sure Sub is correctly frozen.
1211 Freeze_Before
(N
, Entity
(Sub
));
1215 Analyze_And_Resolve
(N
, E_T
);
1217 -- For subsequent analysis, the node must retain its type. The backend
1218 -- will replace it with the equivalent type where needed.
1221 end Expand_Access_To_Protected_Op
;
1223 --------------------------
1224 -- Expand_Fpt_Attribute --
1225 --------------------------
1227 procedure Expand_Fpt_Attribute
1233 Loc
: constant Source_Ptr
:= Sloc
(N
);
1234 Typ
: constant Entity_Id
:= Etype
(N
);
1238 -- The function name is the selected component Attr_xxx.yyy where
1239 -- Attr_xxx is the package name, and yyy is the argument Nam.
1241 -- Note: it would be more usual to have separate RE entries for each
1242 -- of the entities in the Fat packages, but first they have identical
1243 -- names (so we would have to have lots of renaming declarations to
1244 -- meet the normal RE rule of separate names for all runtime entities),
1245 -- and second there would be an awful lot of them.
1248 Make_Selected_Component
(Loc
,
1249 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
1250 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
1252 -- The generated call is given the provided set of parameters, and then
1253 -- wrapped in a conversion which converts the result to the target type.
1257 Make_Function_Call
(Loc
,
1259 Parameter_Associations
=> Args
)));
1261 Analyze_And_Resolve
(N
, Typ
);
1262 end Expand_Fpt_Attribute
;
1264 ----------------------------
1265 -- Expand_Fpt_Attribute_R --
1266 ----------------------------
1268 -- The single argument is converted to its root type to call the
1269 -- appropriate runtime function, with the actual call being built
1270 -- by Expand_Fpt_Attribute
1272 procedure Expand_Fpt_Attribute_R
(N
: Node_Id
) is
1273 E1
: constant Node_Id
:= First
(Expressions
(N
));
1277 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1278 Expand_Fpt_Attribute
1279 (N
, Pkg
, Attribute_Name
(N
),
1280 New_List
(Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
))));
1281 end Expand_Fpt_Attribute_R
;
1283 -----------------------------
1284 -- Expand_Fpt_Attribute_RI --
1285 -----------------------------
1287 -- The first argument is converted to its root type and the second
1288 -- argument is converted to standard long long integer to call the
1289 -- appropriate runtime function, with the actual call being built
1290 -- by Expand_Fpt_Attribute
1292 procedure Expand_Fpt_Attribute_RI
(N
: Node_Id
) is
1293 E1
: constant Node_Id
:= First
(Expressions
(N
));
1294 E2
: constant Node_Id
:= Next
(E1
);
1298 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1299 Expand_Fpt_Attribute
1300 (N
, Pkg
, Attribute_Name
(N
),
1302 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1303 Unchecked_Convert_To
(Standard_Integer
, Relocate_Node
(E2
))));
1304 end Expand_Fpt_Attribute_RI
;
1306 -----------------------------
1307 -- Expand_Fpt_Attribute_RR --
1308 -----------------------------
1310 -- The two arguments are converted to their root types to call the
1311 -- appropriate runtime function, with the actual call being built
1312 -- by Expand_Fpt_Attribute
1314 procedure Expand_Fpt_Attribute_RR
(N
: Node_Id
) is
1315 E1
: constant Node_Id
:= First
(Expressions
(N
));
1316 E2
: constant Node_Id
:= Next
(E1
);
1321 Find_Fat_Info
(Etype
(E1
), Ftp
, Pkg
);
1322 Expand_Fpt_Attribute
1323 (N
, Pkg
, Attribute_Name
(N
),
1325 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E1
)),
1326 Unchecked_Convert_To
(Ftp
, Relocate_Node
(E2
))));
1327 end Expand_Fpt_Attribute_RR
;
1329 ---------------------------------
1330 -- Expand_Loop_Entry_Attribute --
1331 ---------------------------------
1333 procedure Expand_Loop_Entry_Attribute
(N
: Node_Id
) is
1334 procedure Build_Conditional_Block
1337 Loop_Stmt
: Node_Id
;
1338 If_Stmt
: out Node_Id
;
1339 Blk_Stmt
: out Node_Id
);
1340 -- Create a block Blk_Stmt with an empty declarative list and a single
1341 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1342 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1344 function Is_Array_Iteration
(N
: Node_Id
) return Boolean;
1345 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1348 -----------------------------
1349 -- Build_Conditional_Block --
1350 -----------------------------
1352 procedure Build_Conditional_Block
1355 Loop_Stmt
: Node_Id
;
1356 If_Stmt
: out Node_Id
;
1357 Blk_Stmt
: out Node_Id
)
1360 -- Do not reanalyze the original loop statement because it is simply
1363 Set_Analyzed
(Loop_Stmt
);
1366 Make_Block_Statement
(Loc
,
1367 Declarations
=> New_List
,
1368 Handled_Statement_Sequence
=>
1369 Make_Handled_Sequence_Of_Statements
(Loc
,
1370 Statements
=> New_List
(Loop_Stmt
)));
1372 if Present
(Cond
) then
1374 Make_If_Statement
(Loc
,
1376 Then_Statements
=> New_List
(Blk_Stmt
));
1380 end Build_Conditional_Block
;
1382 ------------------------
1383 -- Is_Array_Iteration --
1384 ------------------------
1386 function Is_Array_Iteration
(N
: Node_Id
) return Boolean is
1387 Stmt
: constant Node_Id
:= Original_Node
(N
);
1391 if Nkind
(Stmt
) = N_Loop_Statement
1392 and then Present
(Iteration_Scheme
(Stmt
))
1393 and then Present
(Iterator_Specification
(Iteration_Scheme
(Stmt
)))
1395 Iter
:= Iterator_Specification
(Iteration_Scheme
(Stmt
));
1398 Of_Present
(Iter
) and then Is_Array_Type
(Etype
(Name
(Iter
)));
1402 end Is_Array_Iteration
;
1406 Pref
: constant Node_Id
:= Prefix
(N
);
1407 Base_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Pref
));
1408 Exprs
: constant List_Id
:= Expressions
(N
);
1409 Loc
: constant Source_Ptr
:= Sloc
(N
);
1411 Blk
: Node_Id
:= Empty
;
1413 Installed
: Boolean;
1414 Loop_Id
: Entity_Id
;
1415 Loop_Stmt
: Node_Id
;
1416 Result
: Node_Id
:= Empty
;
1418 Temp_Decl
: Node_Id
;
1419 Temp_Id
: Entity_Id
;
1421 -- Start of processing for Expand_Loop_Entry_Attribute
1424 -- Step 1: Find the related loop
1426 -- The loop label variant of attribute 'Loop_Entry already has all the
1427 -- information in its expression.
1429 if Present
(Exprs
) then
1430 Loop_Id
:= Entity
(First
(Exprs
));
1431 Loop_Stmt
:= Label_Construct
(Parent
(Loop_Id
));
1433 -- Climb the parent chain to find the nearest enclosing loop. Skip
1434 -- all internally generated loops for quantified expressions and for
1435 -- element iterators over multidimensional arrays because the pragma
1436 -- applies to source loop.
1440 while Present
(Loop_Stmt
) loop
1441 if Nkind
(Loop_Stmt
) = N_Loop_Statement
1442 and then Nkind
(Original_Node
(Loop_Stmt
)) = N_Loop_Statement
1443 and then Comes_From_Source
(Original_Node
(Loop_Stmt
))
1448 Loop_Stmt
:= Parent
(Loop_Stmt
);
1451 Loop_Id
:= Entity
(Identifier
(Loop_Stmt
));
1454 -- Step 2: Transform the loop
1456 -- The loop has already been transformed during the expansion of a prior
1457 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1459 if Has_Loop_Entry_Attributes
(Loop_Id
) then
1461 -- When the related loop name appears as the argument of attribute
1462 -- Loop_Entry, the corresponding label construct is the generated
1463 -- block statement. This is because the expander reuses the label.
1465 if Nkind
(Loop_Stmt
) = N_Block_Statement
then
1466 Decls
:= Declarations
(Loop_Stmt
);
1468 -- In all other cases, the loop must appear in the handled sequence
1469 -- of statements of the generated block.
1473 (Nkind
(Parent
(Loop_Stmt
)) = N_Handled_Sequence_Of_Statements
1475 Nkind
(Parent
(Parent
(Loop_Stmt
))) = N_Block_Statement
);
1477 Decls
:= Declarations
(Parent
(Parent
(Loop_Stmt
)));
1480 -- Transform the loop into a conditional block
1483 Set_Has_Loop_Entry_Attributes
(Loop_Id
);
1484 Scheme
:= Iteration_Scheme
(Loop_Stmt
);
1486 -- Infinite loops are transformed into:
1489 -- Temp1 : constant <type of Pref1> := <Pref1>;
1491 -- TempN : constant <type of PrefN> := <PrefN>;
1494 -- <original source statements with attribute rewrites>
1499 Build_Conditional_Block
(Loc
,
1501 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1507 -- While loops are transformed into:
1509 -- function Fnn return Boolean is
1511 -- <condition actions>
1512 -- return <condition>;
1517 -- Temp1 : constant <type of Pref1> := <Pref1>;
1519 -- TempN : constant <type of PrefN> := <PrefN>;
1522 -- <original source statements with attribute rewrites>
1523 -- exit when not Fnn;
1528 -- Note that loops over iterators and containers are already
1529 -- converted into while loops.
1531 elsif Present
(Condition
(Scheme
)) then
1533 Func_Decl
: Node_Id
;
1534 Func_Id
: Entity_Id
;
1538 Func_Id
:= Make_Temporary
(Loc
, 'F');
1540 -- Wrap the condition of the while loop in a Boolean function.
1541 -- This avoids the duplication of the same code which may lead
1542 -- to gigi issues with respect to multiple declaration of the
1543 -- same entity in the presence of side effects or checks. Note
1544 -- that the condition actions must also be relocated into the
1545 -- wrapping function because they may contain itypes, e.g. in
1546 -- the case of a comparison involving slices.
1549 -- <condition actions>
1550 -- return <condition>;
1552 if Present
(Condition_Actions
(Scheme
)) then
1553 Stmts
:= Condition_Actions
(Scheme
);
1559 Make_Simple_Return_Statement
(Loc
,
1561 New_Copy_Tree
(Condition
(Scheme
),
1562 New_Scope
=> Func_Id
)));
1565 -- function Fnn return Boolean is
1571 Make_Subprogram_Body
(Loc
,
1573 Make_Function_Specification
(Loc
,
1574 Defining_Unit_Name
=> Func_Id
,
1575 Result_Definition
=>
1576 New_Occurrence_Of
(Standard_Boolean
, Loc
)),
1577 Declarations
=> Empty_List
,
1578 Handled_Statement_Sequence
=>
1579 Make_Handled_Sequence_Of_Statements
(Loc
,
1580 Statements
=> Stmts
));
1582 -- The function is inserted before the related loop. Make sure
1583 -- to analyze it in the context of the loop's enclosing scope.
1585 Push_Scope
(Scope
(Loop_Id
));
1586 Insert_Action
(Loop_Stmt
, Func_Decl
);
1589 -- The analysis of the condition may have generated entities
1590 -- (such as itypes) that are now used within the function.
1591 -- Adjust their scopes accordingly so that their use appears
1592 -- in their scope of definition.
1598 Ent
:= First_Entity
(Loop_Id
);
1600 while Present
(Ent
) loop
1601 -- Various entities that now occur within the function
1602 -- need to have their scope reset, but not all entities
1603 -- associated with Loop_Id are now inside the function.
1604 -- The function entity itself and loop parameters can
1605 -- be outside the function, and there may be others.
1606 -- It's not clear how the determination of what entity
1607 -- scopes need to be adjusted can be made accurately.
1608 -- Perhaps it will be necessary to traverse the function
1609 -- body to find the exact entities whose scopes need to
1610 -- be reset to the function's Entity_Id. ???
1612 if Ekind
(Ent
) /= E_Loop_Parameter
1613 and then Ent
/= Func_Id
1615 Set_Scope
(Ent
, Func_Id
);
1622 -- Transform the original while loop into an infinite loop
1623 -- where the last statement checks the negated condition. This
1624 -- placement ensures that the condition will not be evaluated
1625 -- twice on the first iteration.
1627 Set_Iteration_Scheme
(Loop_Stmt
, Empty
);
1631 -- exit when not Fnn;
1633 Append_To
(Statements
(Loop_Stmt
),
1634 Make_Exit_Statement
(Loc
,
1638 Make_Function_Call
(Loc
,
1639 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)))));
1641 Build_Conditional_Block
(Loc
,
1643 Make_Function_Call
(Loc
,
1644 Name
=> New_Occurrence_Of
(Func_Id
, Loc
)),
1645 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1650 -- Ada 2012 iteration over an array is transformed into:
1652 -- if <Array_Nam>'Length (1) > 0
1653 -- and then <Array_Nam>'Length (N) > 0
1656 -- Temp1 : constant <type of Pref1> := <Pref1>;
1658 -- TempN : constant <type of PrefN> := <PrefN>;
1660 -- for X in ... loop -- multiple loops depending on dims
1661 -- <original source statements with attribute rewrites>
1666 elsif Is_Array_Iteration
(Loop_Stmt
) then
1668 Array_Nam
: constant Entity_Id
:=
1669 Entity
(Name
(Iterator_Specification
1670 (Iteration_Scheme
(Original_Node
(Loop_Stmt
)))));
1671 Num_Dims
: constant Pos
:=
1672 Number_Dimensions
(Etype
(Array_Nam
));
1673 Cond
: Node_Id
:= Empty
;
1677 -- Generate a check which determines whether all dimensions of
1678 -- the array are non-null.
1680 for Dim
in 1 .. Num_Dims
loop
1684 Make_Attribute_Reference
(Loc
,
1685 Prefix
=> New_Occurrence_Of
(Array_Nam
, Loc
),
1686 Attribute_Name
=> Name_Length
,
1687 Expressions
=> New_List
(
1688 Make_Integer_Literal
(Loc
, Dim
))),
1690 Make_Integer_Literal
(Loc
, 0));
1698 Right_Opnd
=> Check
);
1702 Build_Conditional_Block
(Loc
,
1704 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1709 -- For loops are transformed into:
1711 -- if <Low> <= <High> then
1713 -- Temp1 : constant <type of Pref1> := <Pref1>;
1715 -- TempN : constant <type of PrefN> := <PrefN>;
1717 -- for <Def_Id> in <Low> .. <High> loop
1718 -- <original source statements with attribute rewrites>
1723 elsif Present
(Loop_Parameter_Specification
(Scheme
)) then
1725 Loop_Spec
: constant Node_Id
:=
1726 Loop_Parameter_Specification
(Scheme
);
1731 Subt_Def
:= Discrete_Subtype_Definition
(Loop_Spec
);
1733 -- When the loop iterates over a subtype indication with a
1734 -- range, use the low and high bounds of the subtype itself.
1736 if Nkind
(Subt_Def
) = N_Subtype_Indication
then
1737 Subt_Def
:= Scalar_Range
(Etype
(Subt_Def
));
1740 pragma Assert
(Nkind
(Subt_Def
) = N_Range
);
1747 Left_Opnd
=> New_Copy_Tree
(Low_Bound
(Subt_Def
)),
1748 Right_Opnd
=> New_Copy_Tree
(High_Bound
(Subt_Def
)));
1750 Build_Conditional_Block
(Loc
,
1752 Loop_Stmt
=> Relocate_Node
(Loop_Stmt
),
1758 Decls
:= Declarations
(Blk
);
1761 -- Step 3: Create a constant to capture the value of the prefix at the
1762 -- entry point into the loop.
1764 Temp_Id
:= Make_Temporary
(Loc
, 'P');
1766 -- Preserve the tag of the prefix by offering a specific view of the
1767 -- class-wide version of the prefix.
1769 if Is_Tagged_Type
(Base_Typ
) then
1770 Tagged_Case
: declare
1771 CW_Temp
: Entity_Id
;
1776 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1778 CW_Temp
:= Make_Temporary
(Loc
, 'T');
1779 CW_Typ
:= Class_Wide_Type
(Base_Typ
);
1782 Make_Object_Declaration
(Loc
,
1783 Defining_Identifier
=> CW_Temp
,
1784 Constant_Present
=> True,
1785 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
1787 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
1788 Append_To
(Decls
, Aux_Decl
);
1791 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1794 Make_Object_Renaming_Declaration
(Loc
,
1795 Defining_Identifier
=> Temp_Id
,
1796 Subtype_Mark
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1798 Convert_To
(Base_Typ
, New_Occurrence_Of
(CW_Temp
, Loc
)));
1799 Append_To
(Decls
, Temp_Decl
);
1805 Untagged_Case
: declare
1806 Temp_Expr
: Node_Id
;
1811 -- Generate a nominal type for the constant when the prefix is of
1812 -- a constrained type. This is achieved by setting the Etype of
1813 -- the relocated prefix to its base type. Since the prefix is now
1814 -- the initialization expression of the constant, its freezing
1815 -- will produce a proper nominal type.
1817 Temp_Expr
:= Relocate_Node
(Pref
);
1818 Set_Etype
(Temp_Expr
, Base_Typ
);
1821 -- Temp : constant Base_Typ := Pref;
1824 Make_Object_Declaration
(Loc
,
1825 Defining_Identifier
=> Temp_Id
,
1826 Constant_Present
=> True,
1827 Object_Definition
=> New_Occurrence_Of
(Base_Typ
, Loc
),
1828 Expression
=> Temp_Expr
);
1829 Append_To
(Decls
, Temp_Decl
);
1833 -- Step 4: Analyze all bits
1835 Installed
:= Current_Scope
= Scope
(Loop_Id
);
1837 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1838 -- associated loop, ensure the proper visibility for analysis.
1840 if not Installed
then
1841 Push_Scope
(Scope
(Loop_Id
));
1844 -- Analyze constant declaration with simple value propagation disabled,
1845 -- because the values at the loop entry might be different than the
1846 -- values at the occurrence of Loop_Entry attribute.
1849 Save_Debug_Flag_MM
: constant Boolean := Debug_Flag_MM
;
1851 Debug_Flag_MM
:= True;
1853 if Present
(Aux_Decl
) then
1857 Analyze
(Temp_Decl
);
1859 Debug_Flag_MM
:= Save_Debug_Flag_MM
;
1862 -- If the conditional block has just been created, then analyze it;
1863 -- otherwise it was analyzed when a previous 'Loop_Entry was expanded.
1865 if Present
(Result
) then
1866 Rewrite
(Loop_Stmt
, Result
);
1867 Analyze
(Loop_Stmt
);
1870 Rewrite
(N
, New_Occurrence_Of
(Temp_Id
, Loc
));
1873 if not Installed
then
1876 end Expand_Loop_Entry_Attribute
;
1878 ------------------------------
1879 -- Expand_Min_Max_Attribute --
1880 ------------------------------
1882 procedure Expand_Min_Max_Attribute
(N
: Node_Id
) is
1884 -- Min and Max are handled by the back end (except that static cases
1885 -- have already been evaluated during semantic processing, although the
1886 -- back end should not count on this). The one bit of special processing
1887 -- required in the normal case is that these two attributes typically
1888 -- generate conditionals in the code, so check the relevant restriction.
1890 Check_Restriction
(No_Implicit_Conditionals
, N
);
1891 end Expand_Min_Max_Attribute
;
1893 ----------------------------------
1894 -- Expand_N_Attribute_Reference --
1895 ----------------------------------
1897 procedure Expand_N_Attribute_Reference
(N
: Node_Id
) is
1898 Loc
: constant Source_Ptr
:= Sloc
(N
);
1899 Pref
: constant Node_Id
:= Prefix
(N
);
1900 Exprs
: constant List_Id
:= Expressions
(N
);
1902 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
;
1903 -- Return a small integer type appropriate for the enumeration type
1905 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
);
1906 -- Rewrites an attribute for Read, Write, Output, or Put_Image with a
1907 -- call to the appropriate TSS procedure. Pname is the entity for the
1908 -- procedure to call.
1910 ----------------------
1911 -- Get_Integer_Type --
1912 ----------------------
1914 function Get_Integer_Type
(Typ
: Entity_Id
) return Entity_Id
is
1915 Siz
: constant Uint
:= Esize
(Base_Type
(Typ
));
1918 -- We need to accommodate invalid values of the base type since we
1919 -- accept them for Enum_Rep and Pos, so we reason on the Esize.
1921 return Small_Integer_Type_For
(Siz
, Uns
=> Is_Unsigned_Type
(Typ
));
1922 end Get_Integer_Type
;
1924 ---------------------------------
1925 -- Rewrite_Attribute_Proc_Call --
1926 ---------------------------------
1928 procedure Rewrite_Attribute_Proc_Call
(Pname
: Entity_Id
) is
1929 Item
: constant Node_Id
:= Next
(First
(Exprs
));
1930 Item_Typ
: constant Entity_Id
:= Etype
(Item
);
1931 Formal
: constant Entity_Id
:= Next_Formal
(First_Formal
(Pname
));
1932 Formal_Typ
: constant Entity_Id
:= Etype
(Formal
);
1933 Is_Written
: constant Boolean := Ekind
(Formal
) /= E_In_Parameter
;
1936 -- The expansion depends on Item, the second actual, which is
1937 -- the object being streamed in or out.
1939 -- If the item is a component of a packed array type, and
1940 -- a conversion is needed on exit, we introduce a temporary to
1941 -- hold the value, because otherwise the packed reference will
1942 -- not be properly expanded.
1944 if Nkind
(Item
) = N_Indexed_Component
1945 and then Is_Packed
(Base_Type
(Etype
(Prefix
(Item
))))
1946 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1950 Temp
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
1956 Make_Object_Declaration
(Loc
,
1957 Defining_Identifier
=> Temp
,
1958 Object_Definition
=> New_Occurrence_Of
(Formal_Typ
, Loc
));
1959 Set_Etype
(Temp
, Formal_Typ
);
1962 Make_Assignment_Statement
(Loc
,
1963 Name
=> New_Copy_Tree
(Item
),
1965 Unchecked_Convert_To
1966 (Item_Typ
, New_Occurrence_Of
(Temp
, Loc
)));
1968 Rewrite
(Item
, New_Occurrence_Of
(Temp
, Loc
));
1972 Make_Procedure_Call_Statement
(Loc
,
1973 Name
=> New_Occurrence_Of
(Pname
, Loc
),
1974 Parameter_Associations
=> Exprs
),
1977 Rewrite
(N
, Make_Null_Statement
(Loc
));
1982 -- For the class-wide dispatching cases, and for cases in which
1983 -- the base type of the second argument matches the base type of
1984 -- the corresponding formal parameter (that is to say the stream
1985 -- operation is not inherited), we are all set, and can use the
1986 -- argument unchanged.
1988 if not Is_Class_Wide_Type
(Entity
(Pref
))
1989 and then not Is_Class_Wide_Type
(Etype
(Item
))
1990 and then Base_Type
(Item_Typ
) /= Base_Type
(Formal_Typ
)
1992 -- Perform a view conversion when either the argument or the
1993 -- formal parameter are of a private type.
1995 if Is_Private_Type
(Base_Type
(Formal_Typ
))
1996 or else Is_Private_Type
(Base_Type
(Item_Typ
))
1999 Unchecked_Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
2001 -- Otherwise perform a regular type conversion to ensure that all
2002 -- relevant checks are installed.
2005 Rewrite
(Item
, Convert_To
(Formal_Typ
, Relocate_Node
(Item
)));
2008 -- For untagged derived types set Assignment_OK, to prevent
2009 -- copies from being created when the unchecked conversion
2010 -- is expanded (which would happen in Remove_Side_Effects
2011 -- if Expand_N_Unchecked_Conversion were allowed to call
2012 -- Force_Evaluation). The copy could violate Ada semantics in
2013 -- cases such as an actual that is an out parameter. Note that
2014 -- this approach is also used in exp_ch7 for calls to controlled
2015 -- type operations to prevent problems with actuals wrapped in
2016 -- unchecked conversions.
2018 if Is_Untagged_Derivation
(Etype
(Expression
(Item
))) then
2019 Set_Assignment_OK
(Item
);
2023 -- The stream operation to call might be a renaming created by an
2024 -- attribute definition clause, and might not be frozen yet. Ensure
2025 -- that it has the necessary extra formals.
2027 if not Is_Frozen
(Pname
) then
2028 Create_Extra_Formals
(Pname
);
2031 -- And now rewrite the call
2034 Make_Procedure_Call_Statement
(Loc
,
2035 Name
=> New_Occurrence_Of
(Pname
, Loc
),
2036 Parameter_Associations
=> Exprs
));
2039 end Rewrite_Attribute_Proc_Call
;
2041 Typ
: constant Entity_Id
:= Etype
(N
);
2042 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
2043 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
2044 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
2046 -- Start of processing for Expand_N_Attribute_Reference
2049 -- Do required validity checking, if enabled.
2051 -- Skip check for output parameters of an Asm instruction (since their
2052 -- valuesare not set till after the attribute has been elaborated),
2053 -- for the arguments of a 'Read attribute reference (since the
2054 -- scalar argument is an OUT scalar) and for the arguments of a
2055 -- 'Has_Same_Storage or 'Overlaps_Storage attribute reference (which not
2056 -- considered to be reads of their prefixes and expressions, see Ada RM
2059 if Validity_Checks_On
and then Validity_Check_Operands
2060 and then Id
/= Attribute_Asm_Output
2061 and then Id
/= Attribute_Read
2062 and then Id
/= Attribute_Has_Same_Storage
2063 and then Id
/= Attribute_Overlaps_Storage
2068 Expr
:= First
(Expressions
(N
));
2069 while Present
(Expr
) loop
2070 Ensure_Valid
(Expr
);
2076 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
2077 -- place function, then a temporary return object needs to be created
2078 -- and access to it must be passed to the function.
2080 if Is_Build_In_Place_Function_Call
(Pref
) then
2082 -- If attribute is 'Old, the context is a postcondition, and
2083 -- the temporary must go in the corresponding subprogram, not
2084 -- the postcondition function or any created blocks, as when
2085 -- the attribute appears in a quantified expression. This is
2086 -- handled below in the expansion of the attribute.
2088 if Attribute_Name
(Parent
(Pref
)) = Name_Old
then
2091 Make_Build_In_Place_Call_In_Anonymous_Context
(Pref
);
2094 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
2095 -- containing build-in-place function calls whose returned object covers
2098 elsif Present
(Unqual_BIP_Iface_Function_Call
(Pref
)) then
2099 Make_Build_In_Place_Iface_Call_In_Anonymous_Context
(Pref
);
2102 -- If prefix is a protected type name, this is a reference to the
2103 -- current instance of the type. For a component definition, nothing
2104 -- to do (expansion will occur in the init proc). In other contexts,
2105 -- rewrite into reference to current instance.
2107 if Is_Protected_Self_Reference
(Pref
)
2109 (Nkind
(Parent
(N
)) in N_Index_Or_Discriminant_Constraint
2110 | N_Discriminant_Association
2111 and then Nkind
(Parent
(Parent
(Parent
(Parent
(N
))))) =
2112 N_Component_Definition
)
2114 -- No action needed for these attributes since the current instance
2115 -- will be rewritten to be the name of the _object parameter
2116 -- associated with the enclosing protected subprogram (see below).
2118 and then Id
/= Attribute_Access
2119 and then Id
/= Attribute_Unchecked_Access
2120 and then Id
/= Attribute_Unrestricted_Access
2122 Rewrite
(Pref
, Concurrent_Ref
(Pref
));
2126 -- Remaining processing depends on specific attribute
2128 -- Note: individual sections of the following case statement are
2129 -- allowed to assume there is no code after the case statement, and
2130 -- are legitimately allowed to execute return statements if they have
2131 -- nothing more to do.
2135 -- Attributes related to Ada 2012 iterators. They are only allowed in
2136 -- attribute definition clauses and should never be expanded.
2138 when Attribute_Constant_Indexing
2139 | Attribute_Default_Iterator
2140 | Attribute_Implicit_Dereference
2141 | Attribute_Iterable
2142 | Attribute_Iterator_Element
2143 | Attribute_Variable_Indexing
2145 raise Program_Error
;
2147 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2148 -- were already rejected by the parser. Thus they shouldn't appear here.
2150 when Internal_Attribute_Id
=>
2151 raise Program_Error
;
2157 when Attribute_Access
2158 | Attribute_Unchecked_Access
2159 | Attribute_Unrestricted_Access
2161 Access_Cases
: declare
2162 Ref_Object
: constant Node_Id
:= Get_Referenced_Object
(Pref
);
2163 Btyp_DDT
: Entity_Id
;
2165 procedure Add_Implicit_Interface_Type_Conversion
;
2166 -- Ada 2005 (AI-251): The designated type is an interface type;
2167 -- add an implicit type conversion to force the displacement of
2168 -- the pointer to reference the secondary dispatch table.
2170 function Enclosing_Object
(N
: Node_Id
) return Node_Id
;
2171 -- If N denotes a compound name (selected component, indexed
2172 -- component, or slice), returns the name of the outermost such
2173 -- enclosing object. Otherwise returns N. If the object is a
2174 -- renaming, then the renamed object is returned.
2176 --------------------------------------------
2177 -- Add_Implicit_Interface_Type_Conversion --
2178 --------------------------------------------
2180 procedure Add_Implicit_Interface_Type_Conversion
is
2182 pragma Assert
(Is_Interface
(Btyp_DDT
));
2184 -- Handle cases were no action is required.
2186 if not Comes_From_Source
(N
)
2187 and then not Comes_From_Source
(Ref_Object
)
2188 and then (Nkind
(Ref_Object
) not in N_Has_Chars
2189 or else Chars
(Ref_Object
) /= Name_uInit
)
2196 if Nkind
(Ref_Object
) /= N_Explicit_Dereference
then
2198 -- No implicit conversion required if types match, or if
2199 -- the prefix is the class_wide_type of the interface. In
2200 -- either case passing an object of the interface type has
2201 -- already set the pointer correctly.
2203 if Btyp_DDT
= Etype
(Ref_Object
)
2205 (Is_Class_Wide_Type
(Etype
(Ref_Object
))
2207 Class_Wide_Type
(Btyp_DDT
) = Etype
(Ref_Object
))
2212 Rewrite
(Prefix
(N
),
2213 Convert_To
(Btyp_DDT
,
2214 New_Copy_Tree
(Prefix
(N
))));
2216 Analyze_And_Resolve
(Prefix
(N
), Btyp_DDT
);
2219 -- When the object is an explicit dereference, convert the
2220 -- dereference's prefix.
2224 Obj_DDT
: constant Entity_Id
:=
2226 (Directly_Designated_Type
2227 (Etype
(Prefix
(Ref_Object
))));
2229 -- No implicit conversion required if designated types
2232 if Obj_DDT
/= Btyp_DDT
2233 and then not (Is_Class_Wide_Type
(Obj_DDT
)
2234 and then Etype
(Obj_DDT
) = Btyp_DDT
)
2238 New_Copy_Tree
(Prefix
(Ref_Object
))));
2239 Analyze_And_Resolve
(N
, Typ
);
2243 end Add_Implicit_Interface_Type_Conversion
;
2245 ----------------------
2246 -- Enclosing_Object --
2247 ----------------------
2249 function Enclosing_Object
(N
: Node_Id
) return Node_Id
is
2254 while Nkind
(Obj_Name
) in N_Selected_Component
2255 | N_Indexed_Component
2258 Obj_Name
:= Prefix
(Obj_Name
);
2261 return Get_Referenced_Object
(Obj_Name
);
2262 end Enclosing_Object
;
2264 -- Local declarations
2266 Enc_Object
: Node_Id
:= Enclosing_Object
(Ref_Object
);
2268 -- Start of processing for Access_Cases
2271 Btyp_DDT
:= Designated_Type
(Btyp
);
2273 -- When Enc_Object is a view conversion then RM 3.10.2 (9)
2274 -- applies and we obtain the expression being converted.
2275 -- Otherwise we do not dig any deeper since a conversion
2276 -- might generate a copy and we can't assume it will be as
2277 -- long-lived as the original.
2279 while Nkind
(Enc_Object
) = N_Type_Conversion
2280 and then Is_View_Conversion
(Enc_Object
)
2282 Enc_Object
:= Expression
(Enc_Object
);
2285 -- Handle designated types that come from the limited view
2287 if From_Limited_With
(Btyp_DDT
)
2288 and then Has_Non_Limited_View
(Btyp_DDT
)
2290 Btyp_DDT
:= Non_Limited_View
(Btyp_DDT
);
2293 -- In order to improve the text of error messages, the designated
2294 -- type of access-to-subprogram itypes is set by the semantics as
2295 -- the associated subprogram entity (see sem_attr). Now we replace
2296 -- such node with the proper E_Subprogram_Type itype.
2298 if Id
= Attribute_Unrestricted_Access
2299 and then Is_Subprogram
(Directly_Designated_Type
(Typ
))
2301 -- The following conditions ensure that this special management
2302 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2303 -- At this stage other cases in which the designated type is
2304 -- still a subprogram (instead of an E_Subprogram_Type) are
2305 -- wrong because the semantics must have overridden the type of
2306 -- the node with the type imposed by the context.
2308 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
2309 and then Is_RTE
(Etype
(Parent
(N
)), RE_Prim_Ptr
)
2311 Set_Etype
(N
, RTE
(RE_Prim_Ptr
));
2315 Subp
: constant Entity_Id
:=
2316 Directly_Designated_Type
(Typ
);
2318 Extra
: Entity_Id
:= Empty
;
2319 New_Formal
: Entity_Id
;
2320 Old_Formal
: Entity_Id
:= First_Formal
(Subp
);
2321 Subp_Typ
: Entity_Id
;
2324 Subp_Typ
:= Create_Itype
(E_Subprogram_Type
, N
);
2325 Copy_Strub_Mode
(Subp_Typ
, Subp
);
2326 Set_Etype
(Subp_Typ
, Etype
(Subp
));
2327 Set_Returns_By_Ref
(Subp_Typ
, Returns_By_Ref
(Subp
));
2329 if Present
(Old_Formal
) then
2330 New_Formal
:= New_Copy
(Old_Formal
);
2331 Set_First_Entity
(Subp_Typ
, New_Formal
);
2334 Set_Scope
(New_Formal
, Subp_Typ
);
2335 Etyp
:= Etype
(New_Formal
);
2337 -- Handle itypes. There is no need to duplicate
2338 -- here the itypes associated with record types
2339 -- (i.e the implicit full view of private types).
2342 and then Ekind
(Base_Type
(Etyp
)) /= E_Record_Type
2344 Extra
:= New_Copy
(Etyp
);
2345 Set_Parent
(Extra
, New_Formal
);
2346 Set_Etype
(New_Formal
, Extra
);
2347 Set_Scope
(Extra
, Subp_Typ
);
2350 Extra
:= New_Formal
;
2351 Next_Formal
(Old_Formal
);
2352 exit when No
(Old_Formal
);
2354 Link_Entities
(New_Formal
, New_Copy
(Old_Formal
));
2355 Next_Entity
(New_Formal
);
2358 Unlink_Next_Entity
(New_Formal
);
2359 Set_Last_Entity
(Subp_Typ
, Extra
);
2362 -- Now that the explicit formals have been duplicated,
2363 -- any extra formals needed by the subprogram must be
2366 if Present
(Extra
) then
2367 Set_Extra_Formal
(Extra
, Empty
);
2370 Create_Extra_Formals
(Subp_Typ
);
2371 Set_Directly_Designated_Type
(Typ
, Subp_Typ
);
2376 if Is_Access_Protected_Subprogram_Type
(Btyp
) then
2377 Expand_Access_To_Protected_Op
(N
, Pref
, Typ
);
2379 elsif Is_Access_Subprogram_Type
(Btyp
)
2380 and then Is_Entity_Name
(Pref
)
2382 -- If prefix is a subprogram that has class-wide preconditions
2383 -- and an indirect-call wrapper (ICW) of the subprogram is
2384 -- available then replace the prefix by the ICW.
2386 if Present
(Class_Preconditions
(Entity
(Pref
)))
2387 and then Present
(Indirect_Call_Wrapper
(Entity
(Pref
)))
2391 (Indirect_Call_Wrapper
(Entity
(Pref
)), Loc
));
2392 Analyze_And_Resolve
(N
, Typ
);
2395 -- Ensure the availability of the extra formals to check that
2398 if not Is_Frozen
(Entity
(Pref
))
2399 or else From_Limited_With
(Etype
(Entity
(Pref
)))
2401 Create_Extra_Formals
(Entity
(Pref
));
2404 if not Is_Frozen
(Btyp_DDT
)
2405 or else From_Limited_With
(Etype
(Btyp_DDT
))
2407 Create_Extra_Formals
(Btyp_DDT
);
2411 (Extra_Formals_Match_OK
2412 (E
=> Entity
(Pref
), Ref_E
=> Btyp_DDT
));
2414 -- If prefix is a type name, this is a reference to the current
2415 -- instance of the type, within its initialization procedure.
2417 elsif Is_Entity_Name
(Pref
)
2418 and then Is_Type
(Entity
(Pref
))
2425 -- If the current instance name denotes a task type, then
2426 -- the access attribute is rewritten to be the name of the
2427 -- "_task" parameter associated with the task type's task
2428 -- procedure. An unchecked conversion is applied to ensure
2429 -- a type match in cases of expander-generated calls (e.g.
2432 if Is_Task_Type
(Entity
(Pref
)) then
2434 First_Entity
(Get_Task_Body_Procedure
(Entity
(Pref
)));
2435 while Present
(Formal
) loop
2436 exit when Chars
(Formal
) = Name_uTask
;
2437 Next_Entity
(Formal
);
2440 pragma Assert
(Present
(Formal
));
2443 Unchecked_Convert_To
(Typ
,
2444 New_Occurrence_Of
(Formal
, Loc
)));
2447 elsif Is_Protected_Type
(Entity
(Pref
)) then
2449 -- No action needed for current instance located in a
2450 -- component definition (expansion will occur in the
2453 if Is_Protected_Type
(Current_Scope
) then
2456 -- If the current instance reference is located in a
2457 -- protected subprogram or entry then rewrite the access
2458 -- attribute to be the name of the "_object" parameter.
2459 -- An unchecked conversion is applied to ensure a type
2460 -- match in cases of expander-generated calls (e.g. init
2463 -- The code may be nested in a block, so find enclosing
2464 -- scope that is a protected operation.
2471 Subp
:= Current_Scope
;
2472 while Ekind
(Subp
) in E_Loop | E_Block
loop
2473 Subp
:= Scope
(Subp
);
2478 (Protected_Body_Subprogram
(Subp
));
2480 -- For a protected subprogram the _Object parameter
2481 -- is the protected record, so we create an access
2482 -- to it. The _Object parameter of an entry is an
2485 if Ekind
(Subp
) = E_Entry
then
2487 Unchecked_Convert_To
(Typ
,
2488 New_Occurrence_Of
(Formal
, Loc
)));
2493 Unchecked_Convert_To
(Typ
,
2494 Make_Attribute_Reference
(Loc
,
2495 Attribute_Name
=> Name_Unrestricted_Access
,
2497 New_Occurrence_Of
(Formal
, Loc
))));
2498 Analyze_And_Resolve
(N
);
2503 -- The expression must appear in a default expression,
2504 -- (which in the initialization procedure is the right-hand
2505 -- side of an assignment), and not in a discriminant
2510 while Present
(Par
) loop
2511 exit when Nkind
(Par
) = N_Assignment_Statement
;
2513 if Nkind
(Par
) = N_Component_Declaration
then
2517 Par
:= Parent
(Par
);
2520 if Present
(Par
) then
2522 Make_Attribute_Reference
(Loc
,
2523 Prefix
=> Make_Identifier
(Loc
, Name_uInit
),
2524 Attribute_Name
=> Attribute_Name
(N
)));
2526 Analyze_And_Resolve
(N
, Typ
);
2531 -- If the prefix of an Access attribute is a dereference of an
2532 -- access parameter (or a renaming of such a dereference, or a
2533 -- subcomponent of such a dereference) and the context is a
2534 -- general access type (including the type of an object or
2535 -- component with an access_definition, but not the anonymous
2536 -- type of an access parameter or access discriminant), then
2537 -- apply an accessibility check to the access parameter. We used
2538 -- to rewrite the access parameter as a type conversion, but that
2539 -- could only be done if the immediate prefix of the Access
2540 -- attribute was the dereference, and didn't handle cases where
2541 -- the attribute is applied to a subcomponent of the dereference,
2542 -- since there's generally no available, appropriate access type
2543 -- to convert to in that case. The attribute is passed as the
2544 -- point to insert the check, because the access parameter may
2545 -- come from a renaming, possibly in a different scope, and the
2546 -- check must be associated with the attribute itself.
2548 elsif Id
= Attribute_Access
2549 and then Nkind
(Enc_Object
) = N_Explicit_Dereference
2550 and then Is_Entity_Name
(Prefix
(Enc_Object
))
2551 and then (Ekind
(Btyp
) = E_General_Access_Type
2552 or else Is_Local_Anonymous_Access
(Btyp
))
2553 and then Is_Formal
(Entity
(Prefix
(Enc_Object
)))
2554 and then Ekind
(Etype
(Entity
(Prefix
(Enc_Object
))))
2555 = E_Anonymous_Access_Type
2556 and then Present
(Extra_Accessibility
2557 (Entity
(Prefix
(Enc_Object
))))
2558 and then not No_Dynamic_Accessibility_Checks_Enabled
(Enc_Object
)
2560 Apply_Accessibility_Check
(Prefix
(Enc_Object
), Typ
, N
);
2562 -- Ada 2005 (AI-251): If the designated type is an interface we
2563 -- add an implicit conversion to force the displacement of the
2564 -- pointer to reference the secondary dispatch table.
2566 if Is_Interface
(Btyp_DDT
) then
2567 Add_Implicit_Interface_Type_Conversion
;
2570 -- Ada 2005 (AI-251): If the designated type is an interface we
2571 -- add an implicit conversion to force the displacement of the
2572 -- pointer to reference the secondary dispatch table.
2574 elsif Is_Interface
(Btyp_DDT
) then
2575 Add_Implicit_Interface_Type_Conversion
;
2583 -- Transforms 'Adjacent into a call to the floating-point attribute
2584 -- function Adjacent in Fat_xxx (where xxx is the root type)
2586 when Attribute_Adjacent
=>
2587 Expand_Fpt_Attribute_RR
(N
);
2593 when Attribute_Address
=> Address
: declare
2594 Task_Proc
: Entity_Id
;
2596 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean;
2597 -- Returns True if N is being used to initialize a component of
2598 -- an activation record object where the component corresponds to
2599 -- the object denoted by the prefix of the attribute N.
2601 function Is_Unnested_Component_Init
(N
: Node_Id
) return Boolean is
2603 return Present
(Parent
(N
))
2604 and then Nkind
(Parent
(N
)) = N_Assignment_Statement
2605 and then Is_Entity_Name
(Pref
)
2606 and then Present
(Activation_Record_Component
(Entity
(Pref
)))
2607 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2608 and then Entity
(Selector_Name
(Name
(Parent
(N
)))) =
2609 Activation_Record_Component
(Entity
(Pref
));
2610 end Is_Unnested_Component_Init
;
2612 -- Start of processing for Address
2615 -- If the prefix is a task or a task type, the useful address is that
2616 -- of the procedure for the task body, i.e. the actual program unit.
2617 -- We replace the original entity with that of the procedure.
2619 if Is_Entity_Name
(Pref
)
2620 and then Is_Task_Type
(Entity
(Pref
))
2622 Task_Proc
:= Next_Entity
(Root_Type
(Ptyp
));
2624 while Present
(Task_Proc
) loop
2625 exit when Ekind
(Task_Proc
) = E_Procedure
2626 and then Etype
(First_Formal
(Task_Proc
)) =
2627 Corresponding_Record_Type
(Ptyp
);
2628 Next_Entity
(Task_Proc
);
2631 if Present
(Task_Proc
) then
2632 Set_Entity
(Pref
, Task_Proc
);
2633 Set_Etype
(Pref
, Etype
(Task_Proc
));
2636 -- Similarly, the address of a protected operation is the address
2637 -- of the corresponding protected body, regardless of the protected
2638 -- object from which it is selected.
2640 elsif Nkind
(Pref
) = N_Selected_Component
2641 and then Is_Subprogram
(Entity
(Selector_Name
(Pref
)))
2642 and then Is_Protected_Type
(Scope
(Entity
(Selector_Name
(Pref
))))
2646 External_Subprogram
(Entity
(Selector_Name
(Pref
))), Loc
));
2648 elsif Nkind
(Pref
) = N_Explicit_Dereference
2649 and then Ekind
(Ptyp
) = E_Subprogram_Type
2650 and then Convention
(Ptyp
) = Convention_Protected
2652 -- The prefix is be a dereference of an access_to_protected_
2653 -- subprogram. The desired address is the second component of
2654 -- the record that represents the access.
2657 Addr
: constant Entity_Id
:= Etype
(N
);
2658 Ptr
: constant Node_Id
:= Prefix
(Pref
);
2659 T
: constant Entity_Id
:=
2660 Equivalent_Type
(Base_Type
(Etype
(Ptr
)));
2664 Unchecked_Convert_To
(Addr
,
2665 Make_Selected_Component
(Loc
,
2666 Prefix
=> Unchecked_Convert_To
(T
, Ptr
),
2667 Selector_Name
=> New_Occurrence_Of
(
2668 Next_Entity
(First_Entity
(T
)), Loc
))));
2670 Analyze_And_Resolve
(N
, Addr
);
2673 -- 'Address is an actual parameter of the call to the implicit
2674 -- subprogram To_Pointer instantiated with a class-wide interface
2675 -- type; its expansion requires adding an implicit type conversion
2676 -- to force displacement of the "this" pointer.
2678 elsif Tagged_Type_Expansion
2679 and then Nkind
(Parent
(N
)) = N_Function_Call
2680 and then Nkind
(Name
(Parent
(N
))) in N_Has_Entity
2681 and then Is_Intrinsic_Subprogram
(Entity
(Name
(Parent
(N
))))
2682 and then Chars
(Entity
(Name
(Parent
(N
)))) = Name_To_Pointer
2683 and then Is_Interface
(Designated_Type
(Etype
(Parent
(N
))))
2684 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(Parent
(N
))))
2687 Iface_Typ
: constant Entity_Id
:=
2688 Designated_Type
(Etype
(Parent
(N
)));
2690 Rewrite
(Pref
, Convert_To
(Iface_Typ
, Relocate_Node
(Pref
)));
2691 Analyze_And_Resolve
(Pref
, Iface_Typ
);
2695 -- Ada 2005 (AI-251): Class-wide interface objects are always
2696 -- "displaced" to reference the tag associated with the interface
2697 -- type. In order to obtain the real address of such objects we
2698 -- generate a call to a run-time subprogram that returns the base
2699 -- address of the object. This call is not generated in cases where
2700 -- the attribute is being used to initialize a component of an
2701 -- activation record object where the component corresponds to
2702 -- prefix of the attribute (for back ends that require "unnesting"
2703 -- of nested subprograms), since the address needs to be assigned
2704 -- as-is to such components.
2706 elsif Tagged_Type_Expansion
2707 and then Is_Class_Wide_Type
(Ptyp
)
2708 and then Is_Interface
(Underlying_Type
(Ptyp
))
2709 and then not (Nkind
(Pref
) in N_Has_Entity
2710 and then Is_Subprogram
(Entity
(Pref
)))
2711 and then not Is_Unnested_Component_Init
(N
)
2714 Make_Function_Call
(Loc
,
2715 Name
=> New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
2716 Parameter_Associations
=> New_List
(Relocate_Node
(N
))));
2721 -- Deal with packed array reference, other cases are handled by
2724 if Involves_Packed_Array_Reference
(Pref
) then
2725 Expand_Packed_Address_Reference
(N
);
2733 when Attribute_Alignment
=> Alignment
: declare
2737 -- For class-wide types, X'Class'Alignment is transformed into a
2738 -- direct reference to the Alignment of the class type, so that the
2739 -- back end does not have to deal with the X'Class'Alignment
2742 if Is_Entity_Name
(Pref
)
2743 and then Is_Class_Wide_Type
(Entity
(Pref
))
2745 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
2748 -- For x'Alignment applied to an object of a class wide type,
2749 -- transform X'Alignment into a call to the predefined primitive
2750 -- operation _Alignment applied to X.
2752 elsif Is_Class_Wide_Type
(Ptyp
) then
2754 Make_Attribute_Reference
(Loc
,
2756 Attribute_Name
=> Name_Tag
);
2758 New_Node
:= Build_Get_Alignment
(Loc
, New_Node
);
2760 -- Case where the context is an unchecked conversion to a specific
2761 -- integer type. We directly convert from the alignment's type.
2763 if Nkind
(Parent
(N
)) = N_Unchecked_Type_Conversion
then
2764 Rewrite
(N
, New_Node
);
2765 Analyze_And_Resolve
(N
);
2768 -- Case where the context is a specific integer type with which
2769 -- the original attribute was compatible. But the alignment has a
2770 -- specific type in a-tags.ads (Standard.Natural) so, in order to
2771 -- preserve type compatibility, we must convert explicitly.
2773 elsif Typ
/= Standard_Natural
then
2774 New_Node
:= Convert_To
(Typ
, New_Node
);
2777 Rewrite
(N
, New_Node
);
2778 Analyze_And_Resolve
(N
, Typ
);
2781 -- For all other cases, we just have to deal with the case of
2782 -- the fact that the result can be universal.
2785 Apply_Universal_Integer_Attribute_Checks
(N
);
2789 ---------------------------
2790 -- Asm_Input, Asm_Output --
2791 ---------------------------
2793 -- The Asm_Input and Asm_Output attributes are not expanded at this
2794 -- stage, but will be eliminated in the expansion of the Asm call,
2795 -- see Exp_Intr for details. So the back end will never see them.
2797 when Attribute_Asm_Input
2798 | Attribute_Asm_Output
2806 -- We compute this if a packed array reference was present, otherwise we
2807 -- leave the computation up to the back end.
2809 when Attribute_Bit
=>
2810 if Involves_Packed_Array_Reference
(Pref
) then
2811 Expand_Packed_Bit_Reference
(N
);
2813 Apply_Universal_Integer_Attribute_Checks
(N
);
2820 -- We leave the computation up to the back end, since we don't know what
2821 -- layout will be chosen if no component clause was specified.
2823 when Attribute_Bit_Position
=>
2824 Apply_Universal_Integer_Attribute_Checks
(N
);
2830 -- A reference to P'Body_Version or P'Version is expanded to
2833 -- pragma Import (C, Vnn, "uuuuT");
2835 -- Get_Version_String (Vnn)
2837 -- where uuuu is the unit name (dots replaced by double underscore)
2838 -- and T is B for the cases of Body_Version, or Version applied to a
2839 -- subprogram acting as its own spec, and S for Version applied to a
2840 -- subprogram spec or package. This sequence of code references the
2841 -- unsigned constant created in the main program by the binder.
2843 -- A special exception occurs for Standard, where the string returned
2844 -- is a copy of the library string in gnatvsn.ads.
2846 when Attribute_Body_Version
2850 E
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
2855 -- If not library unit, get to containing library unit
2857 Pent
:= Entity
(Pref
);
2858 while Pent
/= Standard_Standard
2859 and then Scope
(Pent
) /= Standard_Standard
2860 and then not Is_Child_Unit
(Pent
)
2862 Pent
:= Scope
(Pent
);
2865 -- Special case Standard and Standard.ASCII
2867 if Pent
= Standard_Standard
or else Pent
= Standard_ASCII
then
2869 Make_String_Literal
(Loc
,
2870 Strval
=> Verbose_Library_Version
));
2875 -- Build required string constant
2877 Get_Name_String
(Get_Unit_Name
(Pent
));
2880 for J
in 1 .. Name_Len
- 2 loop
2881 if Name_Buffer
(J
) = '.' then
2882 Store_String_Chars
("__");
2884 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
2888 -- Case of subprogram acting as its own spec, always use body
2890 if Nkind
(Declaration_Node
(Pent
)) in N_Subprogram_Specification
2891 and then Nkind
(Parent
(Declaration_Node
(Pent
))) =
2893 and then Acts_As_Spec
(Parent
(Declaration_Node
(Pent
)))
2895 Store_String_Chars
("B");
2897 -- Case of no body present, always use spec
2899 elsif not Unit_Requires_Body
(Pent
) then
2900 Store_String_Chars
("S");
2902 -- Otherwise use B for Body_Version, S for spec
2904 elsif Id
= Attribute_Body_Version
then
2905 Store_String_Chars
("B");
2907 Store_String_Chars
("S");
2911 Lib
.Version_Referenced
(S
);
2913 -- Insert the object declaration
2915 Insert_Actions
(N
, New_List
(
2916 Make_Object_Declaration
(Loc
,
2917 Defining_Identifier
=> E
,
2918 Object_Definition
=>
2919 New_Occurrence_Of
(RTE
(RE_Unsigned
), Loc
))));
2921 -- Set entity as imported with correct external name
2923 Set_Is_Imported
(E
);
2924 Set_Interface_Name
(E
, Make_String_Literal
(Loc
, S
));
2926 -- Set entity as internal to ensure proper Sprint output of its
2927 -- implicit importation.
2929 Set_Is_Internal
(E
);
2931 -- And now rewrite original reference
2934 Make_Function_Call
(Loc
,
2936 New_Occurrence_Of
(RTE
(RE_Get_Version_String
), Loc
),
2937 Parameter_Associations
=> New_List
(
2938 New_Occurrence_Of
(E
, Loc
))));
2941 Analyze_And_Resolve
(N
, RTE
(RE_Version_String
));
2948 -- Transforms 'Ceiling into a call to the floating-point attribute
2949 -- function Ceiling in Fat_xxx (where xxx is the root type)
2951 when Attribute_Ceiling
=>
2952 Expand_Fpt_Attribute_R
(N
);
2958 -- Transforms 'Callable attribute into a call to the Callable function
2960 when Attribute_Callable
=>
2962 -- We have an object of a task interface class-wide type as a prefix
2963 -- to Callable. Generate:
2964 -- callable (Task_Id (Pref._disp_get_task_id));
2966 if Ada_Version
>= Ada_2005
2967 and then Ekind
(Ptyp
) = E_Class_Wide_Type
2968 and then Is_Interface
(Ptyp
)
2969 and then Is_Task_Interface
(Ptyp
)
2972 Make_Function_Call
(Loc
,
2974 New_Occurrence_Of
(RTE
(RE_Callable
), Loc
),
2975 Parameter_Associations
=> New_List
(
2976 Unchecked_Convert_To
2977 (RTE
(RO_ST_Task_Id
),
2978 Build_Disp_Get_Task_Id_Call
(Pref
)))));
2981 Rewrite
(N
, Build_Call_With_Task
(Pref
, RTE
(RE_Callable
)));
2984 Analyze_And_Resolve
(N
, Standard_Boolean
);
2990 -- Transforms 'Caller attribute into a call to either the
2991 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2993 when Attribute_Caller
=> Caller
: declare
2994 Id_Kind
: constant Entity_Id
:= RTE
(RO_AT_Task_Id
);
2995 Ent
: constant Entity_Id
:= Entity
(Pref
);
2996 Conctype
: constant Entity_Id
:= Scope
(Ent
);
2997 Nest_Depth
: Nat
:= 0;
3004 if Is_Protected_Type
(Conctype
) then
3005 case Corresponding_Runtime_Package
(Conctype
) is
3006 when System_Tasking_Protected_Objects_Entries
=>
3009 (RTE
(RE_Protected_Entry_Caller
), Loc
);
3011 when System_Tasking_Protected_Objects_Single_Entry
=>
3014 (RTE
(RE_Protected_Single_Entry_Caller
), Loc
);
3017 raise Program_Error
;
3021 Unchecked_Convert_To
(Id_Kind
,
3022 Make_Function_Call
(Loc
,
3024 Parameter_Associations
=> New_List
(
3026 (Find_Protection_Object
(Current_Scope
), Loc
)))));
3031 -- Determine the nesting depth of the E'Caller attribute, that
3032 -- is, how many accept statements are nested within the accept
3033 -- statement for E at the point of E'Caller. The runtime uses
3034 -- this depth to find the specified entry call.
3036 for J
in reverse 0 .. Scope_Stack
.Last
loop
3037 S
:= Scope_Stack
.Table
(J
).Entity
;
3039 -- We should not reach the scope of the entry, as it should
3040 -- already have been checked in Sem_Attr that this attribute
3041 -- reference is within a matching accept statement.
3043 pragma Assert
(S
/= Conctype
);
3048 elsif Is_Entry
(S
) then
3049 Nest_Depth
:= Nest_Depth
+ 1;
3054 Unchecked_Convert_To
(Id_Kind
,
3055 Make_Function_Call
(Loc
,
3057 New_Occurrence_Of
(RTE
(RE_Task_Entry_Caller
), Loc
),
3058 Parameter_Associations
=> New_List
(
3059 Make_Integer_Literal
(Loc
,
3060 Intval
=> Nest_Depth
)))));
3063 Analyze_And_Resolve
(N
, Id_Kind
);
3066 --------------------
3067 -- Component_Size --
3068 --------------------
3070 -- Component_Size is handled by the back end
3072 when Attribute_Component_Size
=>
3073 Apply_Universal_Integer_Attribute_Checks
(N
);
3079 -- Transforms 'Compose into a call to the floating-point attribute
3080 -- function Compose in Fat_xxx (where xxx is the root type)
3082 -- Note: we strictly should have special code here to deal with the
3083 -- case of absurdly negative arguments (less than Integer'First)
3084 -- which will return a (signed) zero value, but it hardly seems
3085 -- worth the effort. Absurdly large positive arguments will raise
3086 -- constraint error which is fine.
3088 when Attribute_Compose
=>
3089 Expand_Fpt_Attribute_RI
(N
);
3095 when Attribute_Constrained
=> Constrained
: declare
3096 Formal_Ent
: constant Entity_Id
:= Param_Entity
(Pref
);
3099 -- Reference to a parameter where the value is passed as an extra
3100 -- actual, corresponding to the extra formal referenced by the
3101 -- Extra_Constrained field of the corresponding formal. If this
3102 -- is an entry in-parameter, it is replaced by a constant renaming
3103 -- for which Extra_Constrained is never created.
3105 if Present
(Formal_Ent
)
3106 and then Ekind
(Formal_Ent
) /= E_Constant
3107 and then Present
(Extra_Constrained
(Formal_Ent
))
3111 (Extra_Constrained
(Formal_Ent
), Loc
));
3113 -- If the prefix is an access to object, the attribute applies to
3114 -- the designated object, so rewrite with an explicit dereference.
3116 elsif Is_Access_Type
(Ptyp
)
3118 (not Is_Entity_Name
(Pref
) or else Is_Object
(Entity
(Pref
)))
3121 Make_Explicit_Dereference
(Loc
, Relocate_Node
(Pref
)));
3123 -- For variables with a Extra_Constrained field, we use the
3124 -- corresponding entity.
3126 elsif Nkind
(Pref
) = N_Identifier
3127 and then Ekind
(Entity
(Pref
)) = E_Variable
3128 and then Present
(Extra_Constrained
(Entity
(Pref
)))
3132 (Extra_Constrained
(Entity
(Pref
)), Loc
));
3134 -- For all other cases, we can tell at compile time
3137 -- For access type, apply access check as needed
3139 if Is_Entity_Name
(Pref
)
3140 and then not Is_Type
(Entity
(Pref
))
3141 and then Is_Access_Type
(Ptyp
)
3143 Apply_Access_Check
(N
);
3149 (Exp_Util
.Attribute_Constrained_Static_Value
(Pref
)), Loc
));
3152 Analyze_And_Resolve
(N
, Standard_Boolean
);
3159 -- Transforms 'Copy_Sign into a call to the floating-point attribute
3160 -- function Copy_Sign in Fat_xxx (where xxx is the root type).
3162 when Attribute_Copy_Sign
=>
3163 Expand_Fpt_Attribute_RR
(N
);
3169 -- Transforms 'Count attribute into a call to the Count function
3171 when Attribute_Count
=> Count
: declare
3173 Conctyp
: Entity_Id
;
3175 Entry_Id
: Entity_Id
;
3180 -- If the prefix is a member of an entry family, retrieve both
3181 -- entry name and index. For a simple entry there is no index.
3183 if Nkind
(Pref
) = N_Indexed_Component
then
3184 Entnam
:= Prefix
(Pref
);
3185 Index
:= First
(Expressions
(Pref
));
3191 Entry_Id
:= Entity
(Entnam
);
3193 -- Find the concurrent type in which this attribute is referenced
3194 -- (there had better be one).
3196 Conctyp
:= Current_Scope
;
3197 while not Is_Concurrent_Type
(Conctyp
) loop
3198 Conctyp
:= Scope
(Conctyp
);
3203 if Is_Protected_Type
(Conctyp
) then
3205 -- No need to transform 'Count into a function call if the current
3206 -- scope has been eliminated. In this case such transformation is
3207 -- also not viable because the enclosing protected object is not
3210 if Is_Eliminated
(Current_Scope
) then
3214 case Corresponding_Runtime_Package
(Conctyp
) is
3215 when System_Tasking_Protected_Objects_Entries
=>
3216 Name
:= New_Occurrence_Of
(RTE
(RE_Protected_Count
), Loc
);
3219 Make_Function_Call
(Loc
,
3221 Parameter_Associations
=> New_List
(
3223 (Find_Protection_Object
(Current_Scope
), Loc
),
3224 Entry_Index_Expression
3225 (Loc
, Entry_Id
, Index
, Scope
(Entry_Id
))));
3227 when System_Tasking_Protected_Objects_Single_Entry
=>
3229 New_Occurrence_Of
(RTE
(RE_Protected_Count_Entry
), Loc
);
3232 Make_Function_Call
(Loc
,
3234 Parameter_Associations
=> New_List
(
3236 (Find_Protection_Object
(Current_Scope
), Loc
)));
3239 raise Program_Error
;
3246 Make_Function_Call
(Loc
,
3247 Name
=> New_Occurrence_Of
(RTE
(RE_Task_Count
), Loc
),
3248 Parameter_Associations
=> New_List
(
3249 Entry_Index_Expression
(Loc
,
3250 Entry_Id
, Index
, Scope
(Entry_Id
))));
3253 -- The call returns type Natural but the context is universal integer
3254 -- so any integer type is allowed. The attribute was already resolved
3255 -- so its Etype is the required result type. If the base type of the
3256 -- context type is other than Standard.Integer we put in a conversion
3257 -- to the required type. This can be a normal typed conversion since
3258 -- both input and output types of the conversion are integer types
3260 if Base_Type
(Typ
) /= Base_Type
(Standard_Integer
) then
3261 Rewrite
(N
, Convert_To
(Typ
, Call
));
3266 Analyze_And_Resolve
(N
, Typ
);
3269 ---------------------
3270 -- Descriptor_Size --
3271 ---------------------
3273 -- Descriptor_Size is handled by the back end
3275 when Attribute_Descriptor_Size
=>
3276 Apply_Universal_Integer_Attribute_Checks
(N
);
3282 -- This processing is shared by Elab_Spec
3284 -- What we do is to insert the following declarations
3287 -- pragma Import (C, enn, "name___elabb/s");
3289 -- and then the Elab_Body/Spec attribute is replaced by a reference
3290 -- to this defining identifier.
3292 when Attribute_Elab_Body
3293 | Attribute_Elab_Spec
3295 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3296 -- back-end knows how to handle these attributes directly.
3298 if CodePeer_Mode
then
3303 Ent
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E');
3307 procedure Make_Elab_String
(Nod
: Node_Id
);
3308 -- Given Nod, an identifier, or a selected component, put the
3309 -- image into the current string literal, with double underline
3310 -- between components.
3312 ----------------------
3313 -- Make_Elab_String --
3314 ----------------------
3316 procedure Make_Elab_String
(Nod
: Node_Id
) is
3318 if Nkind
(Nod
) = N_Selected_Component
then
3319 Make_Elab_String
(Prefix
(Nod
));
3320 Store_String_Char
('_');
3321 Store_String_Char
('_');
3322 Get_Name_String
(Chars
(Selector_Name
(Nod
)));
3325 pragma Assert
(Nkind
(Nod
) = N_Identifier
);
3326 Get_Name_String
(Chars
(Nod
));
3329 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
3330 end Make_Elab_String
;
3332 -- Start of processing for Elab_Body/Elab_Spec
3335 -- First we need to prepare the string literal for the name of
3336 -- the elaboration routine to be referenced.
3339 Make_Elab_String
(Pref
);
3340 Store_String_Chars
("___elab");
3341 Lang
:= Make_Identifier
(Loc
, Name_C
);
3343 if Id
= Attribute_Elab_Body
then
3344 Store_String_Char
('b');
3346 Store_String_Char
('s');
3351 Insert_Actions
(N
, New_List
(
3352 Make_Subprogram_Declaration
(Loc
,
3354 Make_Procedure_Specification
(Loc
,
3355 Defining_Unit_Name
=> Ent
)),
3358 Chars
=> Name_Import
,
3359 Pragma_Argument_Associations
=> New_List
(
3360 Make_Pragma_Argument_Association
(Loc
, Expression
=> Lang
),
3362 Make_Pragma_Argument_Association
(Loc
,
3363 Expression
=> Make_Identifier
(Loc
, Chars
(Ent
))),
3365 Make_Pragma_Argument_Association
(Loc
,
3366 Expression
=> Make_String_Literal
(Loc
, Str
))))));
3368 Set_Entity
(N
, Ent
);
3369 Rewrite
(N
, New_Occurrence_Of
(Ent
, Loc
));
3372 --------------------
3373 -- Elab_Subp_Body --
3374 --------------------
3376 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3377 -- this attribute directly, and if we are not in CodePeer mode it is
3378 -- entirely ignored ???
3380 when Attribute_Elab_Subp_Body
=>
3387 -- Elaborated is always True for preelaborated units, predefined units,
3388 -- pure units and units which have Elaborate_Body pragmas. These units
3389 -- have no elaboration entity.
3391 -- Note: The Elaborated attribute is never passed to the back end
3393 when Attribute_Elaborated
=> Elaborated
: declare
3394 Elab_Id
: constant Entity_Id
:= Elaboration_Entity
(Entity
(Pref
));
3397 if Present
(Elab_Id
) then
3400 Left_Opnd
=> New_Occurrence_Of
(Elab_Id
, Loc
),
3401 Right_Opnd
=> Make_Integer_Literal
(Loc
, Uint_0
)));
3403 Analyze_And_Resolve
(N
, Typ
);
3405 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
3413 when Attribute_Enum_Rep
=> Enum_Rep
: declare
3417 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3420 if Is_Non_Empty_List
(Exprs
) then
3421 Expr
:= First
(Exprs
);
3426 -- If not constant-folded, Enum_Type'Enum_Rep (X) or X'Enum_Rep
3431 -- This is an unchecked conversion from the enumeration type to the
3432 -- target integer type, which is treated by the back end as a normal
3433 -- integer conversion, treating the enumeration type as an integer,
3434 -- which is exactly what we want. Unlike for the Pos attribute, we
3435 -- cannot use a regular conversion since the associated check would
3436 -- involve comparing the converted bounds, i.e. would involve the use
3437 -- of 'Pos instead 'Enum_Rep for these bounds.
3439 -- However the target type is universal integer in most cases, which
3440 -- is a very large type, so in the case of an enumeration type, we
3441 -- first convert to a small signed integer type in order not to lose
3442 -- the size information.
3444 if Is_Enumeration_Type
(Ptyp
) then
3445 Rewrite
(N
, Unchecked_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
3446 Convert_To_And_Rewrite
(Typ
, N
);
3448 -- Deal with integer types (replace by conversion)
3451 Rewrite
(N
, Convert_To
(Typ
, Expr
));
3454 Analyze_And_Resolve
(N
, Typ
);
3461 when Attribute_Enum_Val
=> Enum_Val
: declare
3463 Btyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
3466 -- X'Enum_Val (Y) expands to
3468 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3471 Expr
:= Unchecked_Convert_To
(Ptyp
, First
(Exprs
));
3473 -- Ensure that the expression is not truncated since the "bad" bits
3476 if Nkind
(Expr
) = N_Unchecked_Type_Conversion
then
3477 Set_No_Truncation
(Expr
);
3481 Make_Raise_Constraint_Error
(Loc
,
3485 Make_Function_Call
(Loc
,
3487 New_Occurrence_Of
(TSS
(Btyp
, TSS_Rep_To_Pos
), Loc
),
3488 Parameter_Associations
=> New_List
(
3489 Relocate_Node
(Duplicate_Subexpr
(Expr
)),
3490 New_Occurrence_Of
(Standard_False
, Loc
))),
3492 Right_Opnd
=> Make_Integer_Literal
(Loc
, -1)),
3493 Reason
=> CE_Range_Check_Failed
));
3496 Analyze_And_Resolve
(N
, Ptyp
);
3503 -- Transforms 'Exponent into a call to the floating-point attribute
3504 -- function Exponent in Fat_xxx (where xxx is the root type)
3506 when Attribute_Exponent
=>
3507 Expand_Fpt_Attribute_R
(N
);
3513 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3515 when Attribute_External_Tag
=>
3517 Make_Function_Call
(Loc
,
3519 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
3520 Parameter_Associations
=> New_List
(
3521 Make_Attribute_Reference
(Loc
,
3522 Attribute_Name
=> Name_Tag
,
3523 Prefix
=> Prefix
(N
)))));
3525 Analyze_And_Resolve
(N
, Standard_String
);
3527 -----------------------
3528 -- Finalization_Size --
3529 -----------------------
3531 when Attribute_Finalization_Size
=> Finalization_Size
: declare
3532 function Calculate_Header_Size
return Node_Id
;
3533 -- Generate a runtime call to calculate the size of the hidden header
3534 -- along with any added padding which would precede a heap-allocated
3535 -- object of the prefix type.
3537 ---------------------------
3538 -- Calculate_Header_Size --
3539 ---------------------------
3541 function Calculate_Header_Size
return Node_Id
is
3544 -- Typ (Header_Size_With_Padding (Pref'Alignment))
3548 Make_Function_Call
(Loc
,
3550 New_Occurrence_Of
(RTE
(RE_Header_Size_With_Padding
), Loc
),
3552 Parameter_Associations
=> New_List
(
3553 Make_Attribute_Reference
(Loc
,
3554 Prefix
=> New_Copy_Tree
(Pref
),
3555 Attribute_Name
=> Name_Alignment
))));
3556 end Calculate_Header_Size
;
3562 -- Start of processing for Finalization_Size
3565 -- An object of a class-wide type first requires a runtime check to
3566 -- determine whether it is actually controlled or not. Depending on
3567 -- the outcome of this check, the Finalization_Size of the object
3568 -- may be zero or some positive value.
3570 -- In this scenario, Pref'Finalization_Size is expanded into
3572 -- Size : Integer := 0;
3574 -- if Needs_Finalization (Pref'Tag) then
3575 -- Size := Integer (Header_Size_With_Padding (Pref'Alignment));
3578 -- and the attribute reference is replaced with a reference to Size.
3580 if Is_Class_Wide_Type
(Ptyp
) then
3581 Size
:= Make_Temporary
(Loc
, 'S');
3583 Insert_Actions
(N
, New_List
(
3586 -- Size : Integer := 0;
3588 Make_Object_Declaration
(Loc
,
3589 Defining_Identifier
=> Size
,
3590 Object_Definition
=>
3591 New_Occurrence_Of
(Standard_Integer
, Loc
),
3592 Expression
=> Make_Integer_Literal
(Loc
, 0)),
3595 -- if Needs_Finalization (Pref'Tag) then
3597 -- Integer (Header_Size_With_Padding (Pref'Alignment));
3600 Make_If_Statement
(Loc
,
3602 Make_Function_Call
(Loc
,
3604 New_Occurrence_Of
(RTE
(RE_Needs_Finalization
), Loc
),
3606 Parameter_Associations
=> New_List
(
3607 Make_Attribute_Reference
(Loc
,
3608 Prefix
=> New_Copy_Tree
(Pref
),
3609 Attribute_Name
=> Name_Tag
))),
3611 Then_Statements
=> New_List
(
3612 Make_Assignment_Statement
(Loc
,
3613 Name
=> New_Occurrence_Of
(Size
, Loc
),
3616 (Standard_Integer
, Calculate_Header_Size
))))));
3618 Rewrite
(N
, New_Occurrence_Of
(Size
, Loc
));
3620 -- The prefix is known to be controlled at compile time. Calculate
3621 -- Finalization_Size by calling function Header_Size_With_Padding.
3623 elsif Needs_Finalization
(Ptyp
) then
3624 Rewrite
(N
, Calculate_Header_Size
);
3626 -- The prefix is not an object with controlled parts, so its
3627 -- Finalization_Size is zero.
3630 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
3633 -- Due to cases where the entity type of the attribute is already
3634 -- resolved the rewritten N must get re-resolved to its appropriate
3637 Analyze_And_Resolve
(N
, Typ
);
3638 end Finalization_Size
;
3644 when Attribute_First
3647 -- If the prefix type is a constrained packed array type which
3648 -- already has a Packed_Array_Impl_Type representation defined, then
3649 -- replace this attribute with a direct reference to the attribute of
3650 -- the appropriate index subtype (since otherwise the back end will
3651 -- try to give us the value of 'First for this implementation type).
3652 -- Do not do this if Ptyp depends on a discriminant as its bounds
3653 -- are only available through N.
3655 if Is_Constrained_Packed_Array
(Ptyp
)
3656 and then not Size_Depends_On_Discriminant
(Ptyp
)
3659 Make_Attribute_Reference
(Loc
,
3660 Attribute_Name
=> Attribute_Name
(N
),
3662 New_Occurrence_Of
(Get_Index_Subtype
(N
), Loc
)));
3663 Analyze_And_Resolve
(N
, Typ
);
3665 -- For a constrained array type, if the bound is a reference to an
3666 -- entity which is not a discriminant, just replace with a direct
3667 -- reference. Note that this must be in keeping with what is done
3668 -- for scalar types in order for range checks to be elided in loops.
3670 -- However, avoid doing it if the array type is public because, in
3671 -- this case, we effectively rely on the back end to create public
3672 -- symbols with consistent names across units for the array bounds.
3674 elsif Is_Array_Type
(Ptyp
)
3675 and then Is_Constrained
(Ptyp
)
3676 and then not Is_Public
(Ptyp
)
3682 if Id
= Attribute_First
then
3683 Bnd
:= Type_Low_Bound
(Get_Index_Subtype
(N
));
3685 Bnd
:= Type_High_Bound
(Get_Index_Subtype
(N
));
3688 if Is_Entity_Name
(Bnd
)
3689 and then Ekind
(Entity
(Bnd
)) /= E_Discriminant
3691 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3695 -- For access type, apply access check as needed
3697 elsif Is_Access_Type
(Ptyp
) then
3698 Apply_Access_Check
(N
);
3700 -- For scalar type, if the bound is a reference to an entity, just
3701 -- replace with a direct reference. Note that we can only have a
3702 -- reference to a constant entity at this stage, anything else would
3703 -- have already been rewritten.
3705 elsif Is_Scalar_Type
(Ptyp
) then
3710 if Id
= Attribute_First
then
3711 Bnd
:= Type_Low_Bound
(Ptyp
);
3713 Bnd
:= Type_High_Bound
(Ptyp
);
3716 if Is_Entity_Name
(Bnd
) then
3717 Rewrite
(N
, New_Occurrence_Of
(Entity
(Bnd
), Loc
));
3726 -- We leave the computation up to the back end, since we don't know what
3727 -- layout will be chosen if no component clause was specified.
3729 when Attribute_First_Bit
=>
3730 Apply_Universal_Integer_Attribute_Checks
(N
);
3732 --------------------------------
3733 -- Fixed_Value, Integer_Value --
3734 --------------------------------
3738 -- fixtype'Fixed_Value (integer-value)
3739 -- inttype'Integer_Value (fixed-value)
3743 -- fixtype (integer-value)
3744 -- inttype (fixed-value)
3748 -- We set Conversion_OK on the conversion because we do not want it
3749 -- to go through the fixed-point conversion circuits.
3751 when Attribute_Fixed_Value
3752 | Attribute_Integer_Value
3754 Rewrite
(N
, OK_Convert_To
(Entity
(Pref
), First
(Exprs
)));
3756 -- Note that it might appear that a properly analyzed unchecked
3757 -- conversion would be just fine here, but that's not the case,
3758 -- since the full range checks performed by the following calls
3761 Apply_Type_Conversion_Checks
(N
);
3763 -- Note that Apply_Type_Conversion_Checks only deals with the
3764 -- overflow checks on conversions involving fixed-point types
3765 -- so we must apply range checks manually on them and expand.
3767 Apply_Scalar_Range_Check
3768 (Expression
(N
), Etype
(N
), Fixed_Int
=> True);
3777 -- Transforms 'Floor into a call to the floating-point attribute
3778 -- function Floor in Fat_xxx (where xxx is the root type)
3780 when Attribute_Floor
=>
3781 Expand_Fpt_Attribute_R
(N
);
3787 -- For the fixed-point type Typ:
3793 -- System.Fore_xx (ftyp (Typ'First), ftyp (Typ'Last) [,pm])
3795 -- For decimal fixed-point types
3796 -- xx = Decimal{32,64,128}
3797 -- ftyp = Integer_{32,64,128}
3800 -- For the most common ordinary fixed-point types
3801 -- xx = Fixed{32,64,128}
3802 -- ftyp = Integer_{32,64,128}
3803 -- pm = numerator of Typ'Small
3804 -- denominator of Typ'Small
3805 -- min (scale of Typ'Small, 0)
3807 -- For other ordinary fixed-point types
3809 -- ftyp = Long_Float
3812 -- Note that we know that the type is a nonstatic subtype, or Fore would
3813 -- have been computed statically in Eval_Attribute.
3815 when Attribute_Fore
=>
3822 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3823 if Esize
(Ptyp
) <= 32 then
3824 Fid
:= RE_Fore_Decimal32
;
3825 Ftyp
:= RTE
(RE_Integer_32
);
3826 elsif Esize
(Ptyp
) <= 64 then
3827 Fid
:= RE_Fore_Decimal64
;
3828 Ftyp
:= RTE
(RE_Integer_64
);
3830 Fid
:= RE_Fore_Decimal128
;
3831 Ftyp
:= RTE
(RE_Integer_128
);
3836 Num
: constant Uint
:= Norm_Num
(Small_Value
(Ptyp
));
3837 Den
: constant Uint
:= Norm_Den
(Small_Value
(Ptyp
));
3838 Max
: constant Uint
:= UI_Max
(Num
, Den
);
3839 Min
: constant Uint
:= UI_Min
(Num
, Den
);
3840 Siz
: constant Uint
:= Esize
(Ptyp
);
3844 and then Max
<= Uint_2
** 31
3845 and then (Min
= Uint_1
3847 or else Num
< Uint_10
** 8)
3849 Fid
:= RE_Fore_Fixed32
;
3850 Ftyp
:= RTE
(RE_Integer_32
);
3852 and then Max
<= Uint_2
** 63
3853 and then (Min
= Uint_1
3855 or else Num
< Uint_10
** 17)
3857 Fid
:= RE_Fore_Fixed64
;
3858 Ftyp
:= RTE
(RE_Integer_64
);
3859 elsif System_Max_Integer_Size
= 128
3860 and then Max
<= Uint_2
** 127
3861 and then (Min
= Uint_1
3863 or else Num
< Uint_10
** 37)
3865 Fid
:= RE_Fore_Fixed128
;
3866 Ftyp
:= RTE
(RE_Integer_128
);
3868 Fid
:= RE_Fore_Fixed
;
3869 Ftyp
:= Standard_Long_Float
;
3874 Arg_List
:= New_List
(
3876 Make_Attribute_Reference
(Loc
,
3877 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3878 Attribute_Name
=> Name_First
)));
3880 Append_To
(Arg_List
,
3882 Make_Attribute_Reference
(Loc
,
3883 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
3884 Attribute_Name
=> Name_Last
)));
3886 -- For decimal, append Scale and also set to do literal conversion
3888 if Is_Decimal_Fixed_Point_Type
(Ptyp
) then
3889 Set_Conversion_OK
(First
(Arg_List
));
3890 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3892 Append_To
(Arg_List
,
3893 Make_Integer_Literal
(Loc
, Scale_Value
(Ptyp
)));
3895 -- For ordinary fixed-point types, append Num, Den and Scale
3896 -- parameters and also set to do literal conversion
3898 elsif Fid
/= RE_Fore_Fixed
then
3899 Set_Conversion_OK
(First
(Arg_List
));
3900 Set_Conversion_OK
(Next
(First
(Arg_List
)));
3902 Append_To
(Arg_List
,
3903 Make_Integer_Literal
(Loc
, -Norm_Num
(Small_Value
(Ptyp
))));
3905 Append_To
(Arg_List
,
3906 Make_Integer_Literal
(Loc
, -Norm_Den
(Small_Value
(Ptyp
))));
3909 Val
: Ureal
:= Small_Value
(Ptyp
);
3913 while Val
>= Ureal_10
loop
3914 Val
:= Val
/ Ureal_10
;
3918 Append_To
(Arg_List
,
3919 Make_Integer_Literal
(Loc
, UI_From_Int
(Scale
)));
3925 Make_Function_Call
(Loc
,
3927 New_Occurrence_Of
(RTE
(Fid
), Loc
),
3928 Parameter_Associations
=> Arg_List
)));
3930 Analyze_And_Resolve
(N
, Typ
);
3937 -- Transforms 'Fraction into a call to the floating-point attribute
3938 -- function Fraction in Fat_xxx (where xxx is the root type)
3940 when Attribute_Fraction
=>
3941 Expand_Fpt_Attribute_R
(N
);
3947 when Attribute_From_Any
=> From_Any
: declare
3948 Decls
: constant List_Id
:= New_List
;
3952 Build_From_Any_Call
(Ptyp
,
3953 Relocate_Node
(First
(Exprs
)),
3955 Insert_Actions
(N
, Decls
);
3956 Analyze_And_Resolve
(N
, Ptyp
);
3959 ----------------------
3960 -- Has_Same_Storage --
3961 ----------------------
3963 when Attribute_Has_Same_Storage
=> Has_Same_Storage
: declare
3964 Loc
: constant Source_Ptr
:= Sloc
(N
);
3966 X
: constant Node_Id
:= Prefix
(N
);
3967 Y
: constant Node_Id
:= First
(Expressions
(N
));
3972 -- Rhe expressions for their addresses
3976 -- Rhe expressions for their sizes
3979 -- The attribute is expanded as:
3981 -- (X'address = Y'address)
3982 -- and then (X'Size = Y'Size)
3983 -- and then (X'Size /= 0) (AI12-0077)
3985 -- If both arguments have the same Etype the second conjunct can be
3989 Make_Attribute_Reference
(Loc
,
3990 Attribute_Name
=> Name_Address
,
3991 Prefix
=> New_Copy_Tree
(X
));
3994 Make_Attribute_Reference
(Loc
,
3995 Attribute_Name
=> Name_Address
,
3996 Prefix
=> New_Copy_Tree
(Y
));
3999 Make_Attribute_Reference
(Loc
,
4000 Attribute_Name
=> Name_Size
,
4001 Prefix
=> New_Copy_Tree
(X
));
4003 if Etype
(X
) = Etype
(Y
) then
4008 Left_Opnd
=> X_Addr
,
4009 Right_Opnd
=> Y_Addr
),
4012 Left_Opnd
=> X_Size
,
4013 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))));
4016 Make_Attribute_Reference
(Loc
,
4017 Attribute_Name
=> Name_Size
,
4018 Prefix
=> New_Copy_Tree
(Y
));
4024 Left_Opnd
=> X_Addr
,
4025 Right_Opnd
=> Y_Addr
),
4030 Left_Opnd
=> X_Size
,
4031 Right_Opnd
=> Y_Size
),
4034 Left_Opnd
=> New_Copy_Tree
(X_Size
),
4035 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)))));
4038 Analyze_And_Resolve
(N
, Standard_Boolean
);
4039 end Has_Same_Storage
;
4045 -- For an exception returns a reference to the exception data:
4046 -- Exception_Id!(Prefix'Reference)
4048 -- For a task it returns a reference to the _task_id component of
4049 -- corresponding record:
4051 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
4053 -- in Ada.Task_Identification
4055 when Attribute_Identity
=> Identity
: declare
4056 Id_Kind
: Entity_Id
;
4059 if Ptyp
= Standard_Exception_Type
then
4060 Id_Kind
:= RTE
(RE_Exception_Id
);
4062 if Present
(Renamed_Entity
(Entity
(Pref
))) then
4063 Set_Entity
(Pref
, Renamed_Entity
(Entity
(Pref
)));
4067 Unchecked_Convert_To
(Id_Kind
, Make_Reference
(Loc
, Pref
)));
4069 Id_Kind
:= RTE
(RO_AT_Task_Id
);
4071 -- If the prefix is a task interface, the Task_Id is obtained
4072 -- dynamically through a dispatching call, as for other task
4073 -- attributes applied to interfaces.
4075 if Ada_Version
>= Ada_2005
4076 and then Ekind
(Ptyp
) = E_Class_Wide_Type
4077 and then Is_Interface
(Ptyp
)
4078 and then Is_Task_Interface
(Ptyp
)
4081 Unchecked_Convert_To
4082 (Id_Kind
, Build_Disp_Get_Task_Id_Call
(Pref
)));
4086 Unchecked_Convert_To
(Id_Kind
, Concurrent_Ref
(Pref
)));
4090 Analyze_And_Resolve
(N
, Id_Kind
);
4097 when Attribute_Image
=>
4099 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
4100 -- back-end knows how to handle this attribute directly.
4102 if CodePeer_Mode
then
4106 Exp_Imgv
.Expand_Image_Attribute
(N
);
4112 -- X'Img is expanded to typ'Image (X), where typ is the type of X
4114 when Attribute_Img
=>
4115 Exp_Imgv
.Expand_Image_Attribute
(N
);
4121 -- Transforms 'Index attribute into a reference to the second formal of
4122 -- the wrapper built for an entry family that has contract cases (see
4123 -- Exp_Ch9.Build_Contract_Wrapper).
4125 when Attribute_Index
=> Index
: declare
4126 Entry_Id
: constant Entity_Id
:= Entity
(Pref
);
4127 Entry_Idx
: constant Entity_Id
:=
4129 (First_Entity
(Contract_Wrapper
(Entry_Id
)));
4131 Rewrite
(N
, New_Occurrence_Of
(Entry_Idx
, Loc
));
4132 Analyze_And_Resolve
(N
, Typ
);
4139 -- For execution, we could either implement an approximation of this
4140 -- aspect, or use Valid_Scalars as a first approximation. For now we do
4143 when Attribute_Initialized
=>
4145 -- Do not expand 'Initialized in CodePeer mode, it will be handled
4146 -- by the back-end directly.
4148 if CodePeer_Mode
then
4154 Make_Attribute_Reference
4157 Attribute_Name
=> Name_Valid_Scalars
,
4158 Expressions
=> Exprs
));
4160 Analyze_And_Resolve
(N
);
4166 when Attribute_Input
=> Input
: declare
4167 P_Type
: constant Entity_Id
:= Entity
(Pref
);
4168 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
4169 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
4170 Strm
: constant Node_Id
:= First
(Exprs
);
4171 Has_TSS
: Boolean := False;
4179 Cntrl
: Node_Id
:= Empty
;
4180 -- Value for controlling argument in call. Always Empty except in
4181 -- the dispatching (class-wide type) case, where it is a reference
4182 -- to the dummy object initialized to the right internal tag.
4184 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
);
4185 -- The expansion of the attribute reference may generate a call to
4186 -- a user-defined stream subprogram that is frozen by the call. This
4187 -- can lead to access-before-elaboration problem if the reference
4188 -- appears in an object declaration and the subprogram body has not
4189 -- been seen. The freezing of the subprogram requires special code
4190 -- because it appears in an expanded context where expressions do
4191 -- not freeze their constituents.
4193 ------------------------------
4194 -- Freeze_Stream_Subprogram --
4195 ------------------------------
4197 procedure Freeze_Stream_Subprogram
(F
: Entity_Id
) is
4198 Decl
: constant Node_Id
:= Unit_Declaration_Node
(F
);
4202 -- If this is user-defined subprogram, the corresponding
4203 -- stream function appears as a renaming-as-body, and the
4204 -- user subprogram must be retrieved by tree traversal.
4207 and then Nkind
(Decl
) = N_Subprogram_Declaration
4208 and then Present
(Corresponding_Body
(Decl
))
4210 Bod
:= Corresponding_Body
(Decl
);
4212 if Nkind
(Unit_Declaration_Node
(Bod
)) =
4213 N_Subprogram_Renaming_Declaration
4215 Set_Is_Frozen
(Entity
(Name
(Unit_Declaration_Node
(Bod
))));
4218 end Freeze_Stream_Subprogram
;
4220 -- Start of processing for Input
4223 -- If no underlying type, we have an error that will be diagnosed
4224 -- elsewhere, so here we just completely ignore the expansion.
4230 -- Stream operations can appear in user code even if the restriction
4231 -- No_Streams is active (for example, when instantiating a predefined
4232 -- container). In that case rewrite the attribute as a Raise to
4233 -- prevent any run-time use.
4235 if Restriction_Active
(No_Streams
) then
4237 Make_Raise_Program_Error
(Sloc
(N
),
4238 Reason
=> PE_Stream_Operation_Not_Allowed
));
4239 Set_Etype
(N
, B_Type
);
4243 -- If there is a TSS for Input, just call it
4245 Fname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Input
, N
);
4247 if Present
(Fname
) then
4251 -- If there is a Stream_Convert pragma, use it, we rewrite
4253 -- sourcetyp'Input (stream)
4257 -- sourcetyp (streamread (strmtyp'Input (stream)));
4259 -- where streamread is the given Read function that converts an
4260 -- argument of type strmtyp to type sourcetyp or a type from which
4261 -- it is derived (extra conversion required for the derived case).
4263 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
4265 if Present
(Prag
) then
4266 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
4267 Rfunc
:= Entity
(Expression
(Arg2
));
4271 Make_Function_Call
(Loc
,
4272 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
4273 Parameter_Associations
=> New_List
(
4274 Make_Attribute_Reference
(Loc
,
4277 (Etype
(First_Formal
(Rfunc
)), Loc
),
4278 Attribute_Name
=> Name_Input
,
4279 Expressions
=> Exprs
)))));
4281 Analyze_And_Resolve
(N
, B_Type
);
4286 elsif Default_Streaming_Unavailable
(U_Type
) then
4287 -- Do the same thing here as is done above in the
4288 -- case where a No_Streams restriction is active.
4291 Make_Raise_Program_Error
(Sloc
(N
),
4292 Reason
=> PE_Stream_Operation_Not_Allowed
));
4293 Set_Etype
(N
, B_Type
);
4298 elsif Is_Elementary_Type
(U_Type
) then
4300 -- A special case arises if we have a defined _Read routine,
4301 -- since in this case we are required to call this routine.
4303 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Read
)) then
4304 Build_Record_Or_Elementary_Input_Function
4305 (P_Type
, Decl
, Fname
);
4306 Insert_Action
(N
, Decl
);
4308 -- For normal cases, we call the I_xxx routine directly
4311 Rewrite
(N
, Build_Elementary_Input_Call
(N
));
4312 Analyze_And_Resolve
(N
, P_Type
);
4318 elsif Is_Array_Type
(U_Type
) then
4319 Build_Array_Input_Function
(U_Type
, Decl
, Fname
);
4320 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
4322 -- Dispatching case with class-wide type
4324 elsif Is_Class_Wide_Type
(P_Type
) then
4326 -- No need to do anything else compiling under restriction
4327 -- No_Dispatching_Calls. During the semantic analysis we
4328 -- already notified such violation.
4330 if Restriction_Active
(No_Dispatching_Calls
) then
4335 Rtyp
: constant Entity_Id
:= Root_Type
(P_Type
);
4337 Expr
: Node_Id
; -- call to Descendant_Tag
4338 Get_Tag
: Node_Id
; -- expression to read the 'Tag
4341 -- Read the internal tag (RM 13.13.2(34)) and use it to
4342 -- initialize a dummy tag value. We used to unconditionally
4345 -- Descendant_Tag (String'Input (Strm), P_Type);
4347 -- which turns into a call to String_Input_Blk_IO. However,
4348 -- if the input is malformed, that could try to read an
4349 -- enormous String, causing chaos. So instead we call
4350 -- String_Input_Tag, which does the same thing as
4351 -- String_Input_Blk_IO, except that if the String is
4352 -- absurdly long, it raises an exception.
4354 -- However, if the No_Stream_Optimizations restriction
4355 -- is active, we disable this unnecessary attempt at
4356 -- robustness; we really need to read the string
4357 -- character-by-character.
4359 -- This value is used only to provide a controlling
4360 -- argument for the eventual _Input call. Descendant_Tag is
4361 -- called rather than Internal_Tag to ensure that we have a
4362 -- tag for a type that is descended from the prefix type and
4363 -- declared at the same accessibility level (the exception
4364 -- Tag_Error will be raised otherwise). The level check is
4365 -- required for Ada 2005 because tagged types can be
4366 -- extended in nested scopes (AI-344).
4368 -- Note: we used to generate an explicit declaration of a
4369 -- constant Ada.Tags.Tag object, and use an occurrence of
4370 -- this constant in Cntrl, but this caused a secondary stack
4373 if Restriction_Active
(No_Stream_Optimizations
) then
4375 Make_Attribute_Reference
(Loc
,
4377 New_Occurrence_Of
(Standard_String
, Loc
),
4378 Attribute_Name
=> Name_Input
,
4379 Expressions
=> New_List
(
4380 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4383 Make_Function_Call
(Loc
,
4386 (RTE
(RE_String_Input_Tag
), Loc
),
4387 Parameter_Associations
=> New_List
(
4388 Relocate_Node
(Duplicate_Subexpr
(Strm
))));
4392 Make_Function_Call
(Loc
,
4394 New_Occurrence_Of
(RTE
(RE_Descendant_Tag
), Loc
),
4395 Parameter_Associations
=> New_List
(
4397 Make_Attribute_Reference
(Loc
,
4398 Prefix
=> New_Occurrence_Of
(P_Type
, Loc
),
4399 Attribute_Name
=> Name_Tag
)));
4401 Set_Etype
(Expr
, RTE
(RE_Tag
));
4403 -- Now we need to get the entity for the call, and construct
4404 -- a function call node, where we preset a reference to Dnn
4405 -- as the controlling argument (doing an unchecked convert
4406 -- to the class-wide tagged type to make it look like a real
4409 Fname
:= Find_Prim_Op
(Rtyp
, TSS_Stream_Input
);
4410 Cntrl
:= Unchecked_Convert_To
(P_Type
, Expr
);
4411 Set_Etype
(Cntrl
, P_Type
);
4412 Set_Parent
(Cntrl
, N
);
4415 -- For tagged types, use the primitive Input function
4417 elsif Is_Tagged_Type
(U_Type
) then
4418 Fname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Input
);
4420 -- All other record type cases, including protected records. The
4421 -- latter only arise for expander generated code for handling
4422 -- shared passive partition access.
4426 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
4428 -- Ada 2005 (AI-216): Program_Error is raised executing default
4429 -- implementation of the Input attribute of an unchecked union
4430 -- type if the type lacks default discriminant values.
4432 if Is_Unchecked_Union
(Base_Type
(U_Type
))
4434 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
4437 Make_Raise_Program_Error
(Loc
,
4438 Reason
=> PE_Unchecked_Union_Restriction
));
4439 Set_Etype
(N
, B_Type
);
4443 -- Build the type's Input function, passing the subtype rather
4444 -- than its base type, because checks are needed in the case of
4445 -- constrained discriminants (see Ada 2012 AI05-0192).
4447 Build_Record_Or_Elementary_Input_Function
4448 (U_Type
, Decl
, Fname
);
4449 Insert_Action
(N
, Decl
);
4451 if Nkind
(Parent
(N
)) = N_Object_Declaration
4452 and then Is_Record_Type
(U_Type
)
4454 -- The stream function may contain calls to user-defined
4455 -- Read procedures for individual components.
4462 Comp
:= First_Component
(U_Type
);
4463 while Present
(Comp
) loop
4465 Find_Stream_Subprogram
4466 (Etype
(Comp
), TSS_Stream_Read
, N
);
4468 if Present
(Func
) then
4469 Freeze_Stream_Subprogram
(Func
);
4472 Next_Component
(Comp
);
4479 -- If we fall through, Fname is the function to be called. The result
4480 -- is obtained by calling the appropriate function, then converting
4481 -- the result. The conversion does a subtype check.
4484 Make_Function_Call
(Loc
,
4485 Name
=> New_Occurrence_Of
(Fname
, Loc
),
4486 Parameter_Associations
=> New_List
(
4487 Relocate_Node
(Strm
)));
4489 Set_Controlling_Argument
(Call
, Cntrl
);
4490 Rewrite
(N
, Unchecked_Convert_To
(P_Type
, Call
));
4491 Analyze_And_Resolve
(N
, P_Type
);
4493 if Nkind
(Parent
(N
)) = N_Object_Declaration
then
4494 Freeze_Stream_Subprogram
(Fname
);
4498 Cached_Streaming_Ops
.Input_Map
.Set
(P_Type
, Fname
);
4506 when Attribute_Invalid_Value
=>
4507 Rewrite
(N
, Get_Simple_Init_Val
(Ptyp
, N
));
4509 -- The value produced may be a conversion of a literal, which must be
4510 -- resolved to establish its proper type.
4512 Analyze_And_Resolve
(N
);
4518 -- We leave the computation up to the back end, since we don't know what
4519 -- layout will be chosen if no component clause was specified.
4521 when Attribute_Last_Bit
=>
4522 Apply_Universal_Integer_Attribute_Checks
(N
);
4528 -- Transforms 'Leading_Part into a call to the floating-point attribute
4529 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4531 -- Note: strictly, we should generate special case code to deal with
4532 -- absurdly large positive arguments (greater than Integer'Last), which
4533 -- result in returning the first argument unchanged, but it hardly seems
4534 -- worth the effort. We raise constraint error for absurdly negative
4535 -- arguments which is fine.
4537 when Attribute_Leading_Part
=>
4538 Expand_Fpt_Attribute_RI
(N
);
4544 when Attribute_Length
=> Length
: declare
4549 -- Processing for packed array types
4551 if Is_Packed_Array
(Ptyp
) then
4552 Ityp
:= Get_Index_Subtype
(N
);
4554 -- If the index type, Ityp, is an enumeration type with holes,
4555 -- then we calculate X'Length explicitly using
4558 -- (0, Ityp'Pos (X'Last (N)) -
4559 -- Ityp'Pos (X'First (N)) + 1);
4561 -- Since the bounds in the template are the representation values
4562 -- and the back end would get the wrong value.
4564 if Is_Enumeration_Type
(Ityp
)
4565 and then Present
(Enum_Pos_To_Rep
(Base_Type
(Ityp
)))
4570 Xnum
:= Expr_Value
(First
(Expressions
(N
)));
4574 Make_Attribute_Reference
(Loc
,
4575 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4576 Attribute_Name
=> Name_Max
,
4577 Expressions
=> New_List
4578 (Make_Integer_Literal
(Loc
, 0),
4582 Make_Op_Subtract
(Loc
,
4584 Make_Attribute_Reference
(Loc
,
4585 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4586 Attribute_Name
=> Name_Pos
,
4588 Expressions
=> New_List
(
4589 Make_Attribute_Reference
(Loc
,
4590 Prefix
=> Duplicate_Subexpr
(Pref
),
4591 Attribute_Name
=> Name_Last
,
4592 Expressions
=> New_List
(
4593 Make_Integer_Literal
(Loc
, Xnum
))))),
4596 Make_Attribute_Reference
(Loc
,
4597 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
),
4598 Attribute_Name
=> Name_Pos
,
4600 Expressions
=> New_List
(
4601 Make_Attribute_Reference
(Loc
,
4603 Duplicate_Subexpr_No_Checks
(Pref
),
4604 Attribute_Name
=> Name_First
,
4605 Expressions
=> New_List
(
4606 Make_Integer_Literal
(Loc
, Xnum
)))))),
4608 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
4610 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
4613 -- If the prefix type is a constrained packed array type which
4614 -- already has a Packed_Array_Impl_Type representation defined,
4615 -- then replace this attribute with a reference to 'Range_Length
4616 -- of the appropriate index subtype (since otherwise the
4617 -- back end will try to give us the value of 'Length for
4618 -- this implementation type).s
4620 elsif Is_Constrained
(Ptyp
) then
4622 Make_Attribute_Reference
(Loc
,
4623 Attribute_Name
=> Name_Range_Length
,
4624 Prefix
=> New_Occurrence_Of
(Ityp
, Loc
)));
4625 Analyze_And_Resolve
(N
, Typ
);
4630 elsif Is_Access_Type
(Ptyp
) then
4631 Apply_Access_Check
(N
);
4633 -- If the designated type is a packed array type, then we convert
4634 -- the reference to:
4637 -- xtyp'Pos (Pref'Last (Expr)) -
4638 -- xtyp'Pos (Pref'First (Expr)));
4640 -- This is a bit complex, but it is the easiest thing to do that
4641 -- works in all cases including enum types with holes xtyp here
4642 -- is the appropriate index type.
4645 Dtyp
: constant Entity_Id
:= Designated_Type
(Ptyp
);
4649 if Is_Packed_Array
(Dtyp
) then
4650 Xtyp
:= Get_Index_Subtype
(N
);
4653 Make_Attribute_Reference
(Loc
,
4654 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
4655 Attribute_Name
=> Name_Max
,
4656 Expressions
=> New_List
(
4657 Make_Integer_Literal
(Loc
, 0),
4660 Make_Integer_Literal
(Loc
, 1),
4661 Make_Op_Subtract
(Loc
,
4663 Make_Attribute_Reference
(Loc
,
4664 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4665 Attribute_Name
=> Name_Pos
,
4666 Expressions
=> New_List
(
4667 Make_Attribute_Reference
(Loc
,
4668 Prefix
=> Duplicate_Subexpr
(Pref
),
4669 Attribute_Name
=> Name_Last
,
4671 New_Copy_List
(Exprs
)))),
4674 Make_Attribute_Reference
(Loc
,
4675 Prefix
=> New_Occurrence_Of
(Xtyp
, Loc
),
4676 Attribute_Name
=> Name_Pos
,
4677 Expressions
=> New_List
(
4678 Make_Attribute_Reference
(Loc
,
4680 Duplicate_Subexpr_No_Checks
(Pref
),
4681 Attribute_Name
=> Name_First
,
4683 New_Copy_List
(Exprs
)))))))));
4685 Analyze_And_Resolve
(N
, Typ
);
4689 -- Otherwise leave it to the back end
4692 Apply_Universal_Integer_Attribute_Checks
(N
);
4696 -- Attribute Loop_Entry is replaced with a reference to a constant value
4697 -- which captures the prefix at the entry point of the related loop. The
4698 -- loop itself may be transformed into a conditional block.
4700 when Attribute_Loop_Entry
=>
4701 Expand_Loop_Entry_Attribute
(N
);
4707 -- Transforms 'Machine into a call to the floating-point attribute
4708 -- function Machine in Fat_xxx (where xxx is the root type).
4709 -- Expansion is avoided for cases the back end can handle directly.
4711 when Attribute_Machine
=>
4712 if not Is_Inline_Floating_Point_Attribute
(N
) then
4713 Expand_Fpt_Attribute_R
(N
);
4716 ----------------------
4717 -- Machine_Rounding --
4718 ----------------------
4720 -- Transforms 'Machine_Rounding into a call to the floating-point
4721 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4722 -- type). Expansion is avoided for cases the back end can handle
4725 when Attribute_Machine_Rounding
=>
4726 if not Is_Inline_Floating_Point_Attribute
(N
) then
4727 Expand_Fpt_Attribute_R
(N
);
4734 -- Machine_Size is equivalent to Object_Size, so transform it into
4735 -- Object_Size and that way the back end never sees Machine_Size.
4737 when Attribute_Machine_Size
=>
4739 Make_Attribute_Reference
(Loc
,
4740 Prefix
=> Prefix
(N
),
4741 Attribute_Name
=> Name_Object_Size
));
4743 Analyze_And_Resolve
(N
, Typ
);
4749 -- The only case that can get this far is the dynamic case of the old
4750 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4757 -- ityp (System.Mantissa.Mantissa_Value
4758 -- (Integer'Integer_Value (typ'First),
4759 -- Integer'Integer_Value (typ'Last)));
4761 when Attribute_Mantissa
=>
4764 Make_Function_Call
(Loc
,
4766 New_Occurrence_Of
(RTE
(RE_Mantissa_Value
), Loc
),
4768 Parameter_Associations
=> New_List
(
4769 Make_Attribute_Reference
(Loc
,
4770 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4771 Attribute_Name
=> Name_Integer_Value
,
4772 Expressions
=> New_List
(
4773 Make_Attribute_Reference
(Loc
,
4774 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4775 Attribute_Name
=> Name_First
))),
4777 Make_Attribute_Reference
(Loc
,
4778 Prefix
=> New_Occurrence_Of
(Standard_Integer
, Loc
),
4779 Attribute_Name
=> Name_Integer_Value
,
4780 Expressions
=> New_List
(
4781 Make_Attribute_Reference
(Loc
,
4782 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
4783 Attribute_Name
=> Name_Last
)))))));
4785 Analyze_And_Resolve
(N
, Typ
);
4791 when Attribute_Max
=>
4792 Expand_Min_Max_Attribute
(N
);
4794 ----------------------------------
4795 -- Max_Size_In_Storage_Elements --
4796 ----------------------------------
4798 when Attribute_Max_Size_In_Storage_Elements
=> declare
4799 Typ
: constant Entity_Id
:= Etype
(N
);
4802 -- If the prefix is X'Class, we transform it into a direct reference
4803 -- to the class-wide type, because the back end must not see a 'Class
4804 -- reference. See also 'Size.
4806 if Is_Entity_Name
(Pref
)
4807 and then Is_Class_Wide_Type
(Entity
(Pref
))
4809 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
4813 -- Heap-allocated controlled objects contain two extra pointers which
4814 -- are not part of the actual type. Transform the attribute reference
4815 -- into a runtime expression to add the size of the hidden header.
4817 if Needs_Finalization
(Ptyp
) and then not Header_Size_Added
(N
) then
4818 Set_Header_Size_Added
(N
);
4821 -- P'Max_Size_In_Storage_Elements +
4822 -- Typ (Header_Size_With_Padding (Ptyp'Alignment))
4826 Left_Opnd
=> Relocate_Node
(N
),
4829 Make_Function_Call
(Loc
,
4832 (RTE
(RE_Header_Size_With_Padding
), Loc
),
4834 Parameter_Associations
=> New_List
(
4835 Make_Attribute_Reference
(Loc
,
4837 New_Occurrence_Of
(Ptyp
, Loc
),
4838 Attribute_Name
=> Name_Alignment
))))));
4840 Analyze_And_Resolve
(N
, Typ
);
4844 -- In the other cases apply the required checks
4846 Apply_Universal_Integer_Attribute_Checks
(N
);
4849 --------------------
4850 -- Mechanism_Code --
4851 --------------------
4853 when Attribute_Mechanism_Code
=>
4855 -- We must replace the prefix in the renamed case
4857 if Is_Entity_Name
(Pref
)
4858 and then Present
(Alias
(Entity
(Pref
)))
4860 Set_Renamed_Subprogram
(Pref
, Alias
(Entity
(Pref
)));
4867 when Attribute_Min
=>
4868 Expand_Min_Max_Attribute
(N
);
4874 when Attribute_Mod
=> Mod_Case
: declare
4875 Arg
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
4876 Hi
: constant Node_Id
:= Type_High_Bound
(Base_Type
(Etype
(Arg
)));
4877 Modv
: constant Uint
:= Modulus
(Btyp
);
4881 -- This is not so simple. The issue is what type to use for the
4882 -- computation of the modular value. In addition we need to use
4883 -- the base type as above to retrieve a static bound for the
4884 -- comparisons that follow.
4886 -- The easy case is when the modulus value is within the bounds
4887 -- of the signed integer type of the argument. In this case we can
4888 -- just do the computation in that signed integer type, and then
4889 -- do an ordinary conversion to the target type.
4891 if Modv
<= Expr_Value
(Hi
) then
4896 Right_Opnd
=> Make_Integer_Literal
(Loc
, Modv
))));
4898 -- Here we know that the modulus is larger than type'Last of the
4899 -- integer type. There are two cases to consider:
4901 -- a) The integer value is non-negative. In this case, it is
4902 -- returned as the result (since it is less than the modulus).
4904 -- b) The integer value is negative. In this case, we know that the
4905 -- result is modulus + value, where the value might be as small as
4906 -- -modulus. The trouble is what type do we use to do the subtract.
4907 -- No type will do, since modulus can be as big as 2**128, and no
4908 -- integer type accommodates this value. Let's do bit of algebra
4911 -- = modulus - (-value)
4912 -- = (modulus - 1) - (-value - 1)
4914 -- Now modulus - 1 is certainly in range of the modular type.
4915 -- -value is in the range 1 .. modulus, so -value -1 is in the
4916 -- range 0 .. modulus-1 which is in range of the modular type.
4917 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4918 -- which we can compute using the integer base type.
4920 -- Once this is done we analyze the if expression without range
4921 -- checks, because we know everything is in range, and we want
4922 -- to prevent spurious warnings on either branch.
4926 Make_If_Expression
(Loc
,
4927 Expressions
=> New_List
(
4929 Left_Opnd
=> Duplicate_Subexpr
(Arg
),
4930 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
4933 Duplicate_Subexpr_No_Checks
(Arg
)),
4935 Make_Op_Subtract
(Loc
,
4937 Make_Integer_Literal
(Loc
,
4938 Intval
=> Modv
- 1),
4944 Left_Opnd
=> Duplicate_Subexpr_No_Checks
(Arg
),
4946 Make_Integer_Literal
(Loc
,
4947 Intval
=> 1))))))));
4951 Analyze_And_Resolve
(N
, Btyp
, Suppress
=> All_Checks
);
4958 -- Transforms 'Model into a call to the floating-point attribute
4959 -- function Model in Fat_xxx (where xxx is the root type).
4960 -- Expansion is avoided for cases the back end can handle directly.
4962 when Attribute_Model
=>
4963 if not Is_Inline_Floating_Point_Attribute
(N
) then
4964 Expand_Fpt_Attribute_R
(N
);
4971 -- The processing for Object_Size shares the processing for Size
4977 when Attribute_Old
=> Old
: declare
4978 CW_Temp
: Entity_Id
;
4985 use Old_Attr_Util
.Conditional_Evaluation
;
4986 use Old_Attr_Util
.Indirect_Temps
;
4988 -- Generating C code we don't need to expand this attribute when
4989 -- we are analyzing the internally built nested _Wrapped_Statements
4990 -- procedure since it will be expanded inline (and later it will
4991 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4992 -- performed in such case then the compiler generates unreferenced
4993 -- extra temporaries.
4995 if Modify_Tree_For_C
4996 and then Chars
(Current_Scope
) = Name_uWrapped_Statements
5001 -- Climb the parent chain looking for subprogram _Wrapped_Statements
5004 while Present
(Subp
) loop
5005 exit when Nkind
(Subp
) = N_Subprogram_Body
5006 and then Chars
(Defining_Entity
(Subp
))
5007 = Name_uWrapped_Statements
;
5009 -- If assertions are disabled, no need to create the declaration
5010 -- that preserves the value. The postcondition pragma in which
5011 -- 'Old appears will be checked or disabled according to the
5012 -- current policy in effect.
5014 if Nkind
(Subp
) = N_Pragma
and then not Is_Checked
(Subp
) then
5018 Subp
:= Parent
(Subp
);
5022 -- 'Old can only appear in the case where local contract-related
5023 -- wrapper has been generated with the purpose of wrapping the
5024 -- original declarations and statements.
5026 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
5028 -- Set the entity kind now in order to mark the temporary as a
5029 -- handler of attribute 'Old's prefix.
5031 Mutate_Ekind
(Temp
, E_Constant
);
5032 Set_Stores_Attribute_Old_Prefix
(Temp
);
5034 -- Push the scope of the related subprogram where _Postcondition
5035 -- resides as this ensures that the object will be analyzed in the
5038 if Present
(Subp
) then
5039 Push_Scope
(Scope
(Defining_Entity
(Subp
)));
5041 -- No need to push the scope when generating C code since the
5042 -- _Postcondition procedure has been inlined.
5048 -- Locate the insertion place of the internal temporary that saves
5051 if Present
(Subp
) then
5054 -- General case where the postcondition checks occur after the call
5055 -- to _Wrapped_Statements.
5059 while Nkind
(Ins_Nod
) /= N_Subprogram_Body
loop
5060 Ins_Nod
:= Parent
(Ins_Nod
);
5063 if Present
(Corresponding_Spec
(Ins_Nod
))
5065 (Wrapped_Statements
(Corresponding_Spec
(Ins_Nod
)))
5067 Ins_Nod
:= Last
(Declarations
(Ins_Nod
));
5069 Ins_Nod
:= First
(Declarations
(Ins_Nod
));
5073 if Eligible_For_Conditional_Evaluation
(N
) then
5075 Eval_Stmts
: constant List_Id
:= New_List
;
5077 procedure Append_For_Indirect_Temp
5078 (N
: Node_Id
; Is_Eval_Stmt
: Boolean);
5079 -- Append either a declaration (which is to be elaborated
5080 -- unconditionally) or an evaluation statement (which is
5081 -- to be executed conditionally).
5083 ------------------------------
5084 -- Append_For_Indirect_Temp --
5085 ------------------------------
5087 procedure Append_For_Indirect_Temp
5088 (N
: Node_Id
; Is_Eval_Stmt
: Boolean)
5091 if Is_Eval_Stmt
then
5092 Append_To
(Eval_Stmts
, N
);
5094 Insert_Before_And_Analyze
(Ins_Nod
, N
);
5096 end Append_For_Indirect_Temp
;
5098 procedure Declare_Indirect_Temporary
is new
5099 Declare_Indirect_Temp
5100 (Append_Item
=> Append_For_Indirect_Temp
);
5102 Declare_Indirect_Temporary
5103 (Attr_Prefix
=> Pref
, Indirect_Temp
=> Temp
);
5105 Insert_After_And_Analyze
(
5109 Condition
=> Conditional_Evaluation_Condition
(N
),
5110 Then_Statements
=> Eval_Stmts
));
5112 Rewrite
(N
, Indirect_Temp_Value
5114 Typ
=> Etype
(Pref
),
5117 if Present
(Subp
) then
5123 -- Preserve the tag of the prefix by offering a specific view of the
5124 -- class-wide version of the prefix.
5126 elsif Is_Tagged_Type
(Typ
) then
5129 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
5131 CW_Temp
:= Make_Temporary
(Loc
, 'T');
5132 CW_Typ
:= Class_Wide_Type
(Typ
);
5135 Make_Object_Declaration
(Loc
,
5136 Defining_Identifier
=> CW_Temp
,
5137 Constant_Present
=> True,
5138 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
5140 Convert_To
(CW_Typ
, Relocate_Node
(Pref
)));
5142 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5145 -- Temp : Typ renames Typ (CW_Temp);
5147 Insert_Before_And_Analyze
(Ins_Nod
,
5148 Make_Object_Renaming_Declaration
(Loc
,
5149 Defining_Identifier
=> Temp
,
5150 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
5152 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
5154 Set_Stores_Attribute_Old_Prefix
(CW_Temp
);
5160 -- Temp : constant Typ := Pref;
5163 Make_Object_Declaration
(Loc
,
5164 Defining_Identifier
=> Temp
,
5165 Constant_Present
=> True,
5166 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
5167 Expression
=> Relocate_Node
(Pref
));
5169 Insert_Before_And_Analyze
(Ins_Nod
, Decl
);
5173 if Present
(Subp
) then
5177 -- Ensure that the prefix of attribute 'Old is valid. The check must
5178 -- be inserted after the expansion of the attribute has taken place
5179 -- to reflect the new placement of the prefix.
5181 if Validity_Checks_On
and then Validity_Check_Operands
then
5183 -- Object declaration that captures the attribute prefix might
5184 -- be rewritten into object renaming declaration.
5186 if Nkind
(Decl
) = N_Object_Declaration
then
5187 Ensure_Valid
(Expression
(Decl
));
5189 pragma Assert
(Nkind
(Decl
) = N_Object_Renaming_Declaration
5190 and then Is_Rewrite_Substitution
(Decl
));
5191 Ensure_Valid
(Name
(Decl
));
5195 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
5198 ----------------------
5199 -- Overlaps_Storage --
5200 ----------------------
5202 when Attribute_Overlaps_Storage
=> Overlaps_Storage
: declare
5203 Loc
: constant Source_Ptr
:= Sloc
(N
);
5204 X
: constant Node_Id
:= Prefix
(N
);
5205 Y
: constant Node_Id
:= First
(Expressions
(N
));
5209 X_Addr
, Y_Addr
: Node_Id
;
5211 -- The expressions for their integer addresses
5213 X_Size
, Y_Size
: Node_Id
;
5215 -- The expressions for their sizes
5220 -- Attribute expands into:
5222 -- (if X'Size = 0 or else Y'Size = 0 then
5225 -- (if X'Address <= Y'Address then
5226 -- (X'Address + X'Size - 1) >= Y'Address
5228 -- (Y'Address + Y'Size - 1) >= X'Address))
5230 -- with the proper address operations. We convert addresses to
5231 -- integer addresses to use predefined arithmetic. The size is
5232 -- expressed in storage units. We add copies of X_Addr and Y_Addr
5233 -- to prevent the appearance of the same node in two places in
5237 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5238 Make_Attribute_Reference
(Loc
,
5239 Attribute_Name
=> Name_Address
,
5240 Prefix
=> New_Copy_Tree
(X
)));
5243 Unchecked_Convert_To
(RTE
(RE_Integer_Address
),
5244 Make_Attribute_Reference
(Loc
,
5245 Attribute_Name
=> Name_Address
,
5246 Prefix
=> New_Copy_Tree
(Y
)));
5249 Make_Op_Divide
(Loc
,
5251 Make_Attribute_Reference
(Loc
,
5252 Attribute_Name
=> Name_Size
,
5253 Prefix
=> New_Copy_Tree
(X
)),
5255 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5258 Make_Op_Divide
(Loc
,
5260 Make_Attribute_Reference
(Loc
,
5261 Attribute_Name
=> Name_Size
,
5262 Prefix
=> New_Copy_Tree
(Y
)),
5264 Make_Integer_Literal
(Loc
, System_Storage_Unit
));
5268 Left_Opnd
=> X_Addr
,
5269 Right_Opnd
=> Y_Addr
);
5271 -- Perform the rewriting
5274 Make_If_Expression
(Loc
, New_List
(
5276 -- Generate a check for zero-sized things like a null record with
5277 -- size zero or an array with zero length since they have no
5278 -- opportunity of overlapping.
5280 -- Without this check, a zero-sized object can trigger a false
5281 -- runtime result if it's compared against another object in
5282 -- its declarative region, due to the zero-sized object having
5283 -- the same address.
5289 Make_Attribute_Reference
(Loc
,
5290 Attribute_Name
=> Name_Size
,
5291 Prefix
=> New_Copy_Tree
(X
)),
5292 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
5296 Make_Attribute_Reference
(Loc
,
5297 Attribute_Name
=> Name_Size
,
5298 Prefix
=> New_Copy_Tree
(Y
)),
5299 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0))),
5301 New_Occurrence_Of
(Standard_False
, Loc
),
5303 -- Non-zero-size overlap check
5305 Make_If_Expression
(Loc
, New_List
(
5311 Left_Opnd
=> New_Copy_Tree
(X_Addr
),
5313 Make_Op_Subtract
(Loc
,
5314 Left_Opnd
=> X_Size
,
5315 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5316 Right_Opnd
=> Y_Addr
),
5321 Left_Opnd
=> New_Copy_Tree
(Y_Addr
),
5323 Make_Op_Subtract
(Loc
,
5324 Left_Opnd
=> Y_Size
,
5325 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1))),
5326 Right_Opnd
=> X_Addr
))))));
5328 Analyze_And_Resolve
(N
, Standard_Boolean
);
5329 end Overlaps_Storage
;
5335 when Attribute_Output
=> Output
: declare
5336 P_Type
: constant Entity_Id
:= Entity
(Pref
);
5337 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
5338 Has_TSS
: Boolean := False;
5346 -- If no underlying type, we have an error that will be diagnosed
5347 -- elsewhere, so here we just completely ignore the expansion.
5353 -- Stream operations can appear in user code even if the restriction
5354 -- No_Streams is active (for example, when instantiating a predefined
5355 -- container). In that case rewrite the attribute as a Raise to
5356 -- prevent any run-time use.
5358 if Restriction_Active
(No_Streams
) then
5360 Make_Raise_Program_Error
(Sloc
(N
),
5361 Reason
=> PE_Stream_Operation_Not_Allowed
));
5362 Set_Etype
(N
, Standard_Void_Type
);
5366 -- If TSS for Output is present, just call it
5368 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Output
, N
);
5370 if Present
(Pname
) then
5374 -- If there is a Stream_Convert pragma, use it, we rewrite
5376 -- sourcetyp'Output (stream, Item)
5380 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5382 -- where strmwrite is the given Write function that converts an
5383 -- argument of type sourcetyp or a type acctyp, from which it is
5384 -- derived to type strmtyp. The conversion to acttyp is required
5385 -- for the derived case.
5387 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
5389 if Present
(Prag
) then
5391 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
5392 Wfunc
:= Entity
(Expression
(Arg3
));
5395 Make_Attribute_Reference
(Loc
,
5396 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
5397 Attribute_Name
=> Name_Output
,
5398 Expressions
=> New_List
(
5399 Relocate_Node
(First
(Exprs
)),
5400 Make_Function_Call
(Loc
,
5401 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
5402 Parameter_Associations
=> New_List
(
5403 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
5404 Relocate_Node
(Next
(First
(Exprs
)))))))));
5411 elsif Default_Streaming_Unavailable
(U_Type
) then
5412 -- Do the same thing here as is done above in the
5413 -- case where a No_Streams restriction is active.
5416 Make_Raise_Program_Error
(Sloc
(N
),
5417 Reason
=> PE_Stream_Operation_Not_Allowed
));
5418 Set_Etype
(N
, Standard_Void_Type
);
5421 -- For elementary types, we call the W_xxx routine directly. Note
5422 -- that the effect of Write and Output is identical for the case
5423 -- of an elementary type (there are no discriminants or bounds).
5425 elsif Is_Elementary_Type
(U_Type
) then
5427 -- A special case arises if we have a defined _Write routine,
5428 -- since in this case we are required to call this routine.
5430 if Present
(Find_Inherited_TSS
(P_Type
, TSS_Stream_Write
)) then
5431 Build_Record_Or_Elementary_Output_Procedure
5432 (P_Type
, Decl
, Pname
);
5433 Insert_Action
(N
, Decl
);
5435 -- For normal cases, we call the W_xxx routine directly
5438 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
5445 elsif Is_Array_Type
(U_Type
) then
5446 Build_Array_Output_Procedure
(U_Type
, Decl
, Pname
);
5447 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
5449 -- Class-wide case, first output external tag, then dispatch
5450 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5452 elsif Is_Class_Wide_Type
(P_Type
) then
5454 -- No need to do anything else compiling under restriction
5455 -- No_Dispatching_Calls. During the semantic analysis we
5456 -- already notified such violation.
5458 if Restriction_Active
(No_Dispatching_Calls
) then
5463 Strm
: constant Node_Id
:= First
(Exprs
);
5464 Item
: constant Node_Id
:= Next
(Strm
);
5467 -- Ada 2005 (AI-344): Check that the accessibility level
5468 -- of the type of the output object is not deeper than
5469 -- that of the attribute's prefix type.
5471 -- if Get_Access_Level (Item'Tag)
5472 -- /= Get_Access_Level (P_Type'Tag)
5477 -- String'Output (Strm, External_Tag (Item'Tag));
5479 -- We cannot figure out a practical way to implement this
5480 -- accessibility check on virtual machines, so we omit it.
5482 if Ada_Version
>= Ada_2005
5483 and then Tagged_Type_Expansion
5486 Make_Implicit_If_Statement
(N
,
5490 Build_Get_Access_Level
(Loc
,
5491 Make_Attribute_Reference
(Loc
,
5494 Duplicate_Subexpr
(Item
,
5496 Attribute_Name
=> Name_Tag
)),
5499 Make_Integer_Literal
(Loc
,
5500 Type_Access_Level
(P_Type
))),
5503 New_List
(Make_Raise_Statement
(Loc
,
5505 RTE
(RE_Tag_Error
), Loc
)))));
5509 Make_Attribute_Reference
(Loc
,
5510 Prefix
=> New_Occurrence_Of
(Standard_String
, Loc
),
5511 Attribute_Name
=> Name_Output
,
5512 Expressions
=> New_List
(
5513 Relocate_Node
(Duplicate_Subexpr
(Strm
)),
5514 Make_Function_Call
(Loc
,
5516 New_Occurrence_Of
(RTE
(RE_External_Tag
), Loc
),
5517 Parameter_Associations
=> New_List
(
5518 Make_Attribute_Reference
(Loc
,
5521 (Duplicate_Subexpr
(Item
, Name_Req
=> True)),
5522 Attribute_Name
=> Name_Tag
))))));
5525 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5527 -- Tagged type case, use the primitive Output function
5529 elsif Is_Tagged_Type
(U_Type
) then
5530 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Output
);
5532 -- All other record type cases, including protected records.
5533 -- The latter only arise for expander generated code for
5534 -- handling shared passive partition access.
5538 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
5540 -- Ada 2005 (AI-216): Program_Error is raised when executing
5541 -- the default implementation of the Output attribute of an
5542 -- unchecked union type if the type lacks default discriminant
5545 if Is_Unchecked_Union
(Base_Type
(U_Type
))
5547 No
(Discriminant_Default_Value
(First_Discriminant
(U_Type
)))
5550 Make_Raise_Program_Error
(Loc
,
5551 Reason
=> PE_Unchecked_Union_Restriction
));
5552 Set_Etype
(N
, Standard_Void_Type
);
5556 Build_Record_Or_Elementary_Output_Procedure
5557 (Base_Type
(U_Type
), Decl
, Pname
);
5558 Insert_Action
(N
, Decl
);
5562 -- If we fall through, Pname is the name of the procedure to call
5564 Rewrite_Attribute_Proc_Call
(Pname
);
5567 Cached_Streaming_Ops
.Output_Map
.Set
(P_Type
, Pname
);
5575 -- For enumeration types, with a non-standard representation we generate
5576 -- a call to the _Rep_To_Pos function created when the type was frozen.
5577 -- The call has the form:
5579 -- _rep_to_pos (expr, flag)
5581 -- The parameter flag is True if range checks are enabled, causing
5582 -- Program_Error to be raised if the expression has an invalid
5583 -- representation, and False if range checks are suppressed.
5585 -- For enumeration types with a standard representation, Pos can be
5586 -- rewritten as a simple conversion with Conversion_OK set.
5588 -- For integer types, Pos is equivalent to a simple integer conversion
5589 -- and we rewrite it as such.
5591 when Attribute_Pos
=> Pos
: declare
5592 Expr
: constant Node_Id
:= First
(Exprs
);
5593 Etyp
: Entity_Id
:= Base_Type
(Ptyp
);
5596 -- Deal with zero/non-zero boolean values
5598 if Is_Boolean_Type
(Etyp
) then
5599 Adjust_Condition
(Expr
);
5600 Etyp
:= Standard_Boolean
;
5601 Set_Prefix
(N
, New_Occurrence_Of
(Standard_Boolean
, Loc
));
5604 -- Case of enumeration type
5606 if Is_Enumeration_Type
(Etyp
) then
5608 -- Non-standard enumeration type (generate call)
5610 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
5611 Append_To
(Exprs
, Rep_To_Pos_Flag
(Etyp
, Loc
));
5614 Make_Function_Call
(Loc
,
5616 New_Occurrence_Of
(TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5617 Parameter_Associations
=> Exprs
)));
5619 -- Standard enumeration type (replace by conversion)
5621 -- This is simply a direct conversion from the enumeration type to
5622 -- the target integer type, which is treated by the back end as a
5623 -- normal integer conversion, treating the enumeration type as an
5624 -- integer, which is exactly what we want. We set Conversion_OK to
5625 -- make sure that the analyzer does not complain about what might
5626 -- be an illegal conversion.
5628 -- However the target type is universal integer in most cases,
5629 -- which is a very large type, so we first convert to a small
5630 -- signed integer type in order not to lose the size information.
5633 Rewrite
(N
, OK_Convert_To
(Get_Integer_Type
(Ptyp
), Expr
));
5634 Convert_To_And_Rewrite
(Typ
, N
);
5638 -- Deal with integer types (replace by conversion)
5641 Rewrite
(N
, Convert_To
(Typ
, Expr
));
5644 Analyze_And_Resolve
(N
, Typ
);
5651 -- We leave the computation up to the back end, since we don't know what
5652 -- layout will be chosen if no component clause was specified.
5654 when Attribute_Position
=>
5655 Apply_Universal_Integer_Attribute_Checks
(N
);
5661 -- 1. Deal with enumeration types with holes.
5662 -- 2. For floating-point, generate call to attribute function.
5663 -- 3. For other cases, deal with constraint checking.
5665 when Attribute_Pred
=> Pred
: declare
5666 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
5669 -- For enumeration types with non-standard representations, we
5670 -- expand typ'Pred (x) into:
5672 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5674 -- if the representation is non-contiguous, and just x - 1 if it is
5675 -- after having dealt with constraint checking.
5677 if Is_Enumeration_Type
(Etyp
)
5678 and then Present
(Enum_Pos_To_Rep
(Etyp
))
5680 if Has_Contiguous_Rep
(Etyp
) then
5681 if not Range_Checks_Suppressed
(Ptyp
) then
5682 Set_Do_Range_Check
(First
(Exprs
), False);
5683 Expand_Pred_Succ_Attribute
(N
);
5687 Unchecked_Convert_To
(Etyp
,
5688 Make_Op_Subtract
(Loc
,
5690 Unchecked_Convert_To
(
5692 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
5695 Make_Integer_Literal
(Loc
, 1))));
5698 -- Add Boolean parameter depending on check suppression
5700 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
5702 Make_Indexed_Component
(Loc
,
5705 (Enum_Pos_To_Rep
(Etyp
), Loc
),
5706 Expressions
=> New_List
(
5707 Make_Op_Subtract
(Loc
,
5709 Make_Function_Call
(Loc
,
5712 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
5713 Parameter_Associations
=> Exprs
),
5714 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
5717 -- Suppress checks since they have all been done above
5719 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
5721 -- For floating-point, we transform 'Pred into a call to the Pred
5722 -- floating-point attribute function in Fat_xxx (xxx is root type).
5723 -- Note that this function takes care of the overflow case.
5725 elsif Is_Floating_Point_Type
(Ptyp
) then
5726 Expand_Fpt_Attribute_R
(N
);
5727 Analyze_And_Resolve
(N
, Typ
);
5729 -- For modular types, nothing to do (no overflow, since wraps)
5731 elsif Is_Modular_Integer_Type
(Ptyp
) then
5734 -- For other types, if argument is marked as needing a range check or
5735 -- overflow checking is enabled, we must generate a check.
5737 elsif not Overflow_Checks_Suppressed
(Ptyp
)
5738 or else Do_Range_Check
(First
(Exprs
))
5740 Set_Do_Range_Check
(First
(Exprs
), False);
5741 Expand_Pred_Succ_Attribute
(N
);
5745 ----------------------------------
5746 -- Preelaborable_Initialization --
5747 ----------------------------------
5749 when Attribute_Preelaborable_Initialization
=>
5751 -- This attribute should already be folded during analysis, but if
5752 -- for some reason it hasn't been, we fold it now.
5757 (Boolean'Pos (Has_Preelaborable_Initialization
(Ptyp
))),
5764 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5766 -- We rewrite X'Priority as the following run-time call:
5768 -- Get_Ceiling (X._Object)
5770 -- Note that although X'Priority is notionally an object, it is quite
5771 -- deliberately not defined as an aliased object in the RM. This means
5772 -- that it works fine to rewrite it as a call, without having to worry
5773 -- about complications that would other arise from X'Priority'Access,
5774 -- which is illegal, because of the lack of aliasing.
5776 when Attribute_Priority
=> Priority
: declare
5778 New_Itype
: Entity_Id
;
5779 Object_Parm
: Node_Id
;
5780 Prottyp
: Entity_Id
;
5785 -- Look for the enclosing protected type
5787 Prottyp
:= Current_Scope
;
5788 while not Is_Protected_Type
(Prottyp
) loop
5789 Prottyp
:= Scope
(Prottyp
);
5792 pragma Assert
(Is_Protected_Type
(Prottyp
));
5794 -- Generate the actual of the call
5796 Subprg
:= Current_Scope
;
5797 while not (Is_Subprogram_Or_Entry
(Subprg
)
5798 and then Present
(Protected_Body_Subprogram
(Subprg
)))
5800 Subprg
:= Scope
(Subprg
);
5803 -- Use of 'Priority inside protected entries and barriers (in both
5804 -- cases the type of the first formal of their expanded subprogram
5807 if Etype
(First_Entity
(Protected_Body_Subprogram
(Subprg
))) =
5810 -- In the expansion of protected entries the type of the first
5811 -- formal of the Protected_Body_Subprogram is an Address. In order
5812 -- to reference the _object component we generate:
5814 -- type T is access p__ptTV;
5817 New_Itype
:= Create_Itype
(E_Access_Type
, N
);
5818 Set_Etype
(New_Itype
, New_Itype
);
5819 Set_Directly_Designated_Type
(New_Itype
,
5820 Corresponding_Record_Type
(Prottyp
));
5821 Freeze_Itype
(New_Itype
, N
);
5824 -- T!(O)._object'unchecked_access
5827 Make_Attribute_Reference
(Loc
,
5829 Make_Selected_Component
(Loc
,
5831 Unchecked_Convert_To
(New_Itype
,
5833 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5835 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5836 Attribute_Name
=> Name_Unchecked_Access
);
5838 -- Use of 'Priority inside a protected subprogram
5842 Make_Attribute_Reference
(Loc
,
5844 Make_Selected_Component
(Loc
,
5847 (First_Entity
(Protected_Body_Subprogram
(Subprg
)),
5849 Selector_Name
=> Make_Identifier
(Loc
, Name_uObject
)),
5850 Attribute_Name
=> Name_Unchecked_Access
);
5853 -- Select the appropriate run-time subprogram
5855 if Has_Entries
(Prottyp
) then
5856 RT_Subprg
:= RO_PE_Get_Ceiling
;
5858 RT_Subprg
:= RE_Get_Ceiling
;
5862 Make_Function_Call
(Loc
,
5864 New_Occurrence_Of
(RTE
(RT_Subprg
), Loc
),
5865 Parameter_Associations
=> New_List
(Object_Parm
));
5869 -- Avoid the generation of extra checks on the pointer to the
5870 -- protected object.
5872 Analyze_And_Resolve
(N
, Typ
, Suppress
=> Access_Check
);
5879 when Attribute_Put_Image
=> Put_Image
: declare
5881 U_Type
: constant Entity_Id
:= Underlying_Type
(Entity
(Pref
));
5886 -- If no underlying type, we have an error that will be diagnosed
5887 -- elsewhere, so here we just completely ignore the expansion.
5893 -- If there is a TSS for Put_Image, just call it. This is true for
5894 -- tagged types (if enabled) and if there is a user-specified
5897 Pname
:= TSS
(U_Type
, TSS_Put_Image
);
5899 if Is_Tagged_Type
(U_Type
) and then Is_Derived_Type
(U_Type
) then
5900 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5902 Pname
:= Find_Inherited_TSS
(U_Type
, TSS_Put_Image
);
5907 -- If Put_Image is disabled, call the "unknown" version
5909 if not Enable_Put_Image
(U_Type
) then
5910 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5914 -- For elementary types, we call the routine in System.Put_Images
5917 elsif Is_Elementary_Type
(U_Type
) then
5918 Rewrite
(N
, Build_Elementary_Put_Image_Call
(N
));
5922 elsif Is_Standard_String_Type
(U_Type
) then
5923 Rewrite
(N
, Build_String_Put_Image_Call
(N
));
5927 elsif Is_Array_Type
(U_Type
) then
5928 Build_Array_Put_Image_Procedure
(N
, U_Type
, Decl
, Pname
);
5929 Insert_Action
(N
, Decl
);
5931 -- Tagged type case, use the primitive Put_Image function. Note
5932 -- that this will dispatch in the class-wide case which is what we
5935 elsif Is_Tagged_Type
(U_Type
) then
5936 Pname
:= Find_Optional_Prim_Op
(U_Type
, TSS_Put_Image
);
5938 -- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
5939 -- because we might be deriving from a predefined type, which
5940 -- currently has Enable_Put_Image False.
5943 Rewrite
(N
, Build_Unknown_Put_Image_Call
(N
));
5948 elsif Is_Protected_Type
(U_Type
) then
5949 Rewrite
(N
, Build_Protected_Put_Image_Call
(N
));
5953 elsif Is_Task_Type
(U_Type
) then
5954 Rewrite
(N
, Build_Task_Put_Image_Call
(N
));
5958 -- All other record type cases
5961 pragma Assert
(Is_Record_Type
(U_Type
));
5962 Build_Record_Put_Image_Procedure
5963 (Loc
, Full_Base
(U_Type
), Decl
, Pname
);
5964 Insert_Action
(N
, Decl
);
5968 -- If we fall through, Pname is the procedure to be called
5970 Rewrite_Attribute_Proc_Call
(Pname
);
5977 when Attribute_Range_Length
=>
5979 -- The only special processing required is for the case where
5980 -- Range_Length is applied to an enumeration type with holes.
5981 -- In this case we transform
5987 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5989 -- So that the result reflects the proper Pos values instead
5990 -- of the underlying representations.
5992 if Is_Enumeration_Type
(Ptyp
)
5993 and then Has_Non_Standard_Rep
(Ptyp
)
5998 Make_Op_Subtract
(Loc
,
6000 Make_Attribute_Reference
(Loc
,
6001 Attribute_Name
=> Name_Pos
,
6002 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6003 Expressions
=> New_List
(
6004 Make_Attribute_Reference
(Loc
,
6005 Attribute_Name
=> Name_Last
,
6007 New_Occurrence_Of
(Ptyp
, Loc
)))),
6010 Make_Attribute_Reference
(Loc
,
6011 Attribute_Name
=> Name_Pos
,
6012 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
6013 Expressions
=> New_List
(
6014 Make_Attribute_Reference
(Loc
,
6015 Attribute_Name
=> Name_First
,
6017 New_Occurrence_Of
(Ptyp
, Loc
))))),
6019 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)));
6021 Analyze_And_Resolve
(N
, Typ
);
6023 -- For all other cases, the attribute is handled by the back end, but
6024 -- we need to deal with the case of the range check on a universal
6028 Apply_Universal_Integer_Attribute_Checks
(N
);
6035 when Attribute_Reduce
=>
6037 Loc
: constant Source_Ptr
:= Sloc
(N
);
6038 E1
: constant Node_Id
:= First
(Expressions
(N
));
6039 E2
: constant Node_Id
:= Next
(E1
);
6040 Bnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'B', N
);
6042 Accum_Typ
: Entity_Id
;
6045 function Build_Stat
(Comp
: Node_Id
) return Node_Id
;
6046 -- The reducer can be a function, a procedure whose first
6047 -- parameter is in-out, or an attribute that is a function,
6048 -- which (for now) can only be Min/Max. This subprogram
6049 -- builds the corresponding computation for the generated loop
6050 -- and retrieves the accumulator type as per RM 4.5.10(19/5).
6056 function Build_Stat
(Comp
: Node_Id
) return Node_Id
is
6060 if Nkind
(E1
) = N_Attribute_Reference
then
6061 Accum_Typ
:= Entity
(Prefix
(E1
));
6062 Stat
:= Make_Assignment_Statement
(Loc
,
6063 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
6064 Expression
=> Make_Attribute_Reference
(Loc
,
6065 Attribute_Name
=> Attribute_Name
(E1
),
6066 Prefix
=> New_Copy
(Prefix
(E1
)),
6067 Expressions
=> New_List
(
6068 New_Occurrence_Of
(Bnn
, Loc
),
6071 elsif Ekind
(Entity
(E1
)) = E_Procedure
then
6072 Accum_Typ
:= Etype
(First_Formal
(Entity
(E1
)));
6073 Stat
:= Make_Procedure_Call_Statement
(Loc
,
6074 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
6075 Parameter_Associations
=> New_List
(
6076 New_Occurrence_Of
(Bnn
, Loc
),
6079 Accum_Typ
:= Etype
(Entity
(E1
));
6080 Stat
:= Make_Assignment_Statement
(Loc
,
6081 Name
=> New_Occurrence_Of
(Bnn
, Loc
),
6082 Expression
=> Make_Function_Call
(Loc
,
6083 Name
=> New_Occurrence_Of
(Entity
(E1
), Loc
),
6084 Parameter_Associations
=> New_List
(
6085 New_Occurrence_Of
(Bnn
, Loc
),
6092 -- If the prefix is an aggregate, its unique component is an
6093 -- Iterated_Element, and we create a loop out of its iterator.
6094 -- The iterated_component_association is parsed as a loop parameter
6095 -- specification with "in" or as a container iterator with "of".
6098 if Nkind
(Prefix
(N
)) = N_Aggregate
then
6100 Stream
: constant Node_Id
:=
6101 First
(Component_Associations
(Prefix
(N
)));
6102 Expr
: constant Node_Id
:= Expression
(Stream
);
6103 Id
: constant Node_Id
:= Defining_Identifier
(Stream
);
6104 It_Spec
: constant Node_Id
:=
6105 Iterator_Specification
(Stream
);
6110 -- Iteration may be given by an element iterator:
6112 if Nkind
(Stream
) = N_Iterated_Component_Association
6113 and then Present
(It_Spec
)
6114 and then Of_Present
(It_Spec
)
6117 Make_Iteration_Scheme
(Loc
,
6118 Iterator_Specification
=>
6119 Relocate_Node
(It_Spec
),
6120 Loop_Parameter_Specification
=> Empty
);
6123 Ch
:= First
(Discrete_Choices
(Stream
));
6125 Make_Iteration_Scheme
(Loc
,
6126 Iterator_Specification
=> Empty
,
6127 Loop_Parameter_Specification
=>
6128 Make_Loop_Parameter_Specification
(Loc
,
6129 Defining_Identifier
=> New_Copy
(Id
),
6130 Discrete_Subtype_Definition
=>
6131 Relocate_Node
(Ch
)));
6134 New_Loop
:= Make_Loop_Statement
(Loc
,
6135 Iteration_Scheme
=> Iter
,
6138 New_List
(Build_Stat
(Relocate_Node
(Expr
))));
6140 -- If the reducer subprogram is a universal operator, then
6141 -- we still look at the context to find the type for now.
6143 if Is_Universal_Numeric_Type
(Accum_Typ
) then
6144 Accum_Typ
:= Etype
(N
);
6149 -- If the prefix is a name, we construct an element iterator
6150 -- over it. Its expansion will verify that it is an array or
6151 -- a container with the proper aspects.
6154 Elem
: constant Entity_Id
:= Make_Temporary
(Loc
, 'E', N
);
6160 Make_Iterator_Specification
(Loc
,
6161 Defining_Identifier
=> Elem
,
6162 Name
=> Relocate_Node
(Prefix
(N
)),
6163 Subtype_Indication
=> Empty
);
6164 Set_Of_Present
(Iter
);
6166 New_Loop
:= Make_Loop_Statement
(Loc
,
6168 Make_Iteration_Scheme
(Loc
,
6169 Iterator_Specification
=> Iter
,
6170 Loop_Parameter_Specification
=> Empty
),
6172 Statements
=> New_List
(
6173 Build_Stat
(New_Occurrence_Of
(Elem
, Loc
))));
6175 -- If the reducer subprogram is a universal operator, then
6176 -- we need to look at the prefix to find the type. This is
6177 -- modeled on Analyze_Iterator_Specification in Sem_Ch5.
6179 if Is_Universal_Numeric_Type
(Accum_Typ
) then
6181 Ptyp
: constant Entity_Id
:=
6182 Base_Type
(Etype
(Prefix
(N
)));
6185 if Is_Array_Type
(Ptyp
) then
6186 Accum_Typ
:= Component_Type
(Ptyp
);
6188 elsif Has_Aspect
(Ptyp
, Aspect_Iterable
) then
6190 Element
: constant Entity_Id
:=
6191 Get_Iterable_Type_Primitive
6192 (Ptyp
, Name_Element
);
6194 if Present
(Element
) then
6195 Accum_Typ
:= Etype
(Element
);
6201 Element
: constant Node_Id
:=
6202 Find_Value_Of_Aspect
6203 (Ptyp
, Aspect_Iterator_Element
);
6205 if Present
(Element
) then
6206 Accum_Typ
:= Entity
(Element
);
6216 Make_Expression_With_Actions
(Loc
,
6217 Actions
=> New_List
(
6218 Make_Object_Declaration
(Loc
,
6219 Defining_Identifier
=> Bnn
,
6220 Object_Definition
=>
6221 New_Occurrence_Of
(Accum_Typ
, Loc
),
6222 Expression
=> Relocate_Node
(E2
)), New_Loop
),
6223 Expression
=> New_Occurrence_Of
(Bnn
, Loc
)));
6225 Analyze_And_Resolve
(N
, Accum_Typ
);
6232 when Attribute_Read
=> Read
: declare
6233 P_Type
: constant Entity_Id
:= Entity
(Pref
);
6234 B_Type
: constant Entity_Id
:= Base_Type
(P_Type
);
6235 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
6236 Has_TSS
: Boolean := False;
6246 -- If no underlying type, we have an error that will be diagnosed
6247 -- elsewhere, so here we just completely ignore the expansion.
6253 -- Stream operations can appear in user code even if the restriction
6254 -- No_Streams is active (for example, when instantiating a predefined
6255 -- container). In that case rewrite the attribute as a Raise to
6256 -- prevent any run-time use.
6258 if Restriction_Active
(No_Streams
) then
6260 Make_Raise_Program_Error
(Sloc
(N
),
6261 Reason
=> PE_Stream_Operation_Not_Allowed
));
6262 Set_Etype
(N
, B_Type
);
6266 -- The simple case, if there is a TSS for Read, just call it
6268 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Read
, N
);
6270 if Present
(Pname
) then
6274 -- If there is a Stream_Convert pragma, use it, we rewrite
6276 -- sourcetyp'Read (stream, Item)
6280 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
6282 -- where strmread is the given Read function that converts an
6283 -- argument of type strmtyp to type sourcetyp or a type from which
6284 -- it is derived. The conversion to sourcetyp is required in the
6287 -- A special case arises if Item is a type conversion in which
6288 -- case, we have to expand to:
6290 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
6292 -- where Itemx is the expression of the type conversion (i.e.
6293 -- the actual object), and typex is the type of Itemx.
6295 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
6297 if Present
(Prag
) then
6298 Arg2
:= Next
(First
(Pragma_Argument_Associations
(Prag
)));
6299 Rfunc
:= Entity
(Expression
(Arg2
));
6300 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6302 OK_Convert_To
(B_Type
,
6303 Make_Function_Call
(Loc
,
6304 Name
=> New_Occurrence_Of
(Rfunc
, Loc
),
6305 Parameter_Associations
=> New_List
(
6306 Make_Attribute_Reference
(Loc
,
6309 (Etype
(First_Formal
(Rfunc
)), Loc
),
6310 Attribute_Name
=> Name_Input
,
6311 Expressions
=> New_List
(
6312 Relocate_Node
(First
(Exprs
)))))));
6314 if Nkind
(Lhs
) = N_Type_Conversion
then
6315 Lhs
:= Expression
(Lhs
);
6316 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6320 Make_Assignment_Statement
(Loc
,
6322 Expression
=> Rhs
));
6323 Set_Assignment_OK
(Lhs
);
6329 elsif Default_Streaming_Unavailable
(U_Type
) then
6330 -- Do the same thing here as is done above in the
6331 -- case where a No_Streams restriction is active.
6334 Make_Raise_Program_Error
(Sloc
(N
),
6335 Reason
=> PE_Stream_Operation_Not_Allowed
));
6336 Set_Etype
(N
, B_Type
);
6339 -- For elementary types, we call the I_xxx routine using the first
6340 -- parameter and then assign the result into the second parameter.
6341 -- We set Assignment_OK to deal with the conversion case.
6343 elsif Is_Elementary_Type
(U_Type
) then
6349 Lhs
:= Relocate_Node
(Next
(First
(Exprs
)));
6350 Rhs
:= Build_Elementary_Input_Call
(N
);
6352 if Nkind
(Lhs
) = N_Type_Conversion
then
6353 Lhs
:= Expression
(Lhs
);
6354 Rhs
:= Convert_To
(Etype
(Lhs
), Rhs
);
6357 Set_Assignment_OK
(Lhs
);
6360 Make_Assignment_Statement
(Loc
,
6362 Expression
=> Rhs
));
6370 elsif Is_Array_Type
(U_Type
) then
6371 Build_Array_Read_Procedure
(U_Type
, Decl
, Pname
);
6372 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
6374 -- Tagged type case, use the primitive Read function. Note that
6375 -- this will dispatch in the class-wide case which is what we want
6377 elsif Is_Tagged_Type
(U_Type
) then
6378 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Read
);
6380 -- All other record type cases, including protected records. The
6381 -- latter only arise for expander generated code for handling
6382 -- shared passive partition access.
6386 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
6388 -- Ada 2005 (AI-216): Program_Error is raised when executing
6389 -- the default implementation of the Read attribute of an
6390 -- Unchecked_Union type. We replace the attribute with a
6391 -- raise statement (rather than inserting it before) to handle
6392 -- properly the case of an unchecked union that is a record
6395 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
6397 Make_Raise_Program_Error
(Loc
,
6398 Reason
=> PE_Unchecked_Union_Restriction
));
6399 Set_Etype
(N
, B_Type
);
6403 if Has_Defaulted_Discriminants
(U_Type
) then
6404 Build_Mutable_Record_Read_Procedure
6405 (Full_Base
(U_Type
), Decl
, Pname
);
6407 Build_Record_Read_Procedure
6408 (Full_Base
(U_Type
), Decl
, Pname
);
6411 Insert_Action
(N
, Decl
);
6415 Rewrite_Attribute_Proc_Call
(Pname
);
6418 Cached_Streaming_Ops
.Read_Map
.Set
(P_Type
, Pname
);
6426 -- Ref is identical to To_Address, see To_Address for processing
6432 -- Transforms 'Remainder into a call to the floating-point attribute
6433 -- function Remainder in Fat_xxx (where xxx is the root type)
6435 when Attribute_Remainder
=>
6436 Expand_Fpt_Attribute_RR
(N
);
6442 -- Transform 'Result into reference to _Result formal. At the point
6443 -- where a legal 'Result attribute is expanded, we know that we are in
6444 -- the context of a _Postcondition function with a _Result parameter.
6446 when Attribute_Result
=>
6447 Rewrite
(N
, Make_Identifier
(Loc
, Chars
=> Name_uResult
));
6448 Analyze_And_Resolve
(N
, Typ
);
6454 -- The handling of the Round attribute is delicate when the operand is
6455 -- universal fixed. In this case, the processing in Sem_Attr introduced
6456 -- a conversion to universal real, reflecting the semantics of Round,
6457 -- but we do not want anything to do with universal real at run time,
6458 -- since this corresponds to using floating-point arithmetic.
6460 -- What we have now is that the Etype of the Round attribute correctly
6461 -- indicates the final result type. The operand of the Round is the
6462 -- conversion to universal real, described above, and the operand of
6463 -- this conversion is the actual operand of Round, which may be the
6464 -- special case of a fixed point multiplication or division.
6466 -- The expander will expand first the operand of the conversion, then
6467 -- the conversion, and finally the round attribute itself, since we
6468 -- always work inside out. But we cannot simply process naively in this
6469 -- order. In the semantic world where universal fixed and real really
6470 -- exist and have infinite precision, there is no problem, but in the
6471 -- implementation world, where universal real is a floating-point type,
6472 -- we would get the wrong result.
6474 -- So the approach is as follows. When expanding a multiply or divide
6475 -- whose type is universal fixed, Fixup_Universal_Fixed_Operation will
6476 -- look up and skip the conversion to universal real if its parent is
6477 -- a Round attribute, taking information from this attribute node. In
6478 -- the other cases, Expand_N_Type_Conversion does the same by looking
6479 -- at its parent to see if it is a Round attribute, before calling the
6480 -- fixed-point expansion routine.
6482 -- This means that by the time we get to expanding the Round attribute
6483 -- itself, the Round is nothing more than a type conversion (and will
6484 -- often be a null type conversion), so we just replace it with the
6485 -- appropriate conversion operation.
6487 when Attribute_Round
=>
6488 if Etype
(First
(Exprs
)) = Etype
(N
) then
6489 Rewrite
(N
, Relocate_Node
(First
(Exprs
)));
6491 Rewrite
(N
, Convert_To
(Etype
(N
), First
(Exprs
)));
6492 Set_Rounded_Result
(N
);
6494 Analyze_And_Resolve
(N
);
6500 -- Transforms 'Rounding into a call to the floating-point attribute
6501 -- function Rounding in Fat_xxx (where xxx is the root type)
6502 -- Expansion is avoided for cases the back end can handle directly.
6504 when Attribute_Rounding
=>
6505 if not Is_Inline_Floating_Point_Attribute
(N
) then
6506 Expand_Fpt_Attribute_R
(N
);
6513 -- Transforms 'Scaling into a call to the floating-point attribute
6514 -- function Scaling in Fat_xxx (where xxx is the root type)
6516 when Attribute_Scaling
=>
6517 Expand_Fpt_Attribute_RI
(N
);
6519 ----------------------------------------
6520 -- Simple_Storage_Pool & Storage_Pool --
6521 ----------------------------------------
6523 when Attribute_Simple_Storage_Pool | Attribute_Storage_Pool
=>
6525 Make_Type_Conversion
(Loc
,
6526 Subtype_Mark
=> New_Occurrence_Of
(Etype
(N
), Loc
),
6527 Expression
=> New_Occurrence_Of
(Entity
(N
), Loc
)));
6528 Analyze_And_Resolve
(N
, Typ
);
6534 when Attribute_Object_Size
6536 | Attribute_Value_Size
6537 | Attribute_VADS_Size
6543 -- Processing for VADS_Size case. Note that this processing
6544 -- removes all traces of VADS_Size from the tree, and completes
6545 -- all required processing for VADS_Size by translating the
6546 -- attribute reference to an appropriate Size or Object_Size
6549 if Id
= Attribute_VADS_Size
6550 or else (Use_VADS_Size
and then Id
= Attribute_Size
)
6552 -- If the size is specified, then we simply use the specified
6553 -- size. This applies to both types and objects. The size of an
6554 -- object can be specified in the following ways:
6556 -- An explicit size clause is given for an object
6557 -- A component size is specified for an indexed component
6558 -- A component clause is specified for a selected component
6559 -- The object is a component of a packed composite object
6561 -- If the size is specified, then VADS_Size of an object
6563 if (Is_Entity_Name
(Pref
)
6564 and then Present
(Size_Clause
(Entity
(Pref
))))
6566 (Nkind
(Pref
) = N_Component_Clause
6567 and then (Present
(Component_Clause
6568 (Entity
(Selector_Name
(Pref
))))
6569 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6571 (Nkind
(Pref
) = N_Indexed_Component
6572 and then (Known_Component_Size
(Etype
(Prefix
(Pref
)))
6573 or else Is_Packed
(Etype
(Prefix
(Pref
)))))
6575 Set_Attribute_Name
(N
, Name_Size
);
6577 -- Otherwise if we have an object rather than a type, then
6578 -- the VADS_Size attribute applies to the type of the object,
6579 -- rather than the object itself. This is one of the respects
6580 -- in which VADS_Size differs from Size.
6583 if (not Is_Entity_Name
(Pref
)
6584 or else not Is_Type
(Entity
(Pref
)))
6585 and then (Is_Scalar_Type
(Ptyp
)
6586 or else Is_Constrained
(Ptyp
))
6588 Rewrite
(Pref
, New_Occurrence_Of
(Ptyp
, Loc
));
6591 -- For a scalar type for which no size was explicitly given,
6592 -- VADS_Size means Object_Size. This is the other respect in
6593 -- which VADS_Size differs from Size.
6595 if Is_Scalar_Type
(Ptyp
)
6596 and then No
(Size_Clause
(Ptyp
))
6598 Set_Attribute_Name
(N
, Name_Object_Size
);
6600 -- In all other cases, Size and VADS_Size are the same
6603 Set_Attribute_Name
(N
, Name_Size
);
6608 -- If the prefix is X'Class, transform it into a direct reference
6609 -- to the class-wide type, because the back end must not see a
6610 -- 'Class reference.
6612 if Is_Entity_Name
(Pref
)
6613 and then Is_Class_Wide_Type
(Entity
(Pref
))
6615 Rewrite
(Prefix
(N
), New_Occurrence_Of
(Entity
(Pref
), Loc
));
6618 -- For X'Size applied to an object of a class-wide type, transform
6619 -- X'Size into a call to the primitive operation _Size applied to
6622 elsif Is_Class_Wide_Type
(Ptyp
) then
6624 -- No need to do anything else compiling under restriction
6625 -- No_Dispatching_Calls. During the semantic analysis we
6626 -- already noted this restriction violation.
6628 if Restriction_Active
(No_Dispatching_Calls
) then
6633 Make_Function_Call
(Loc
,
6635 New_Occurrence_Of
(Find_Prim_Op
(Ptyp
, Name_uSize
), Loc
),
6636 Parameter_Associations
=> New_List
(Pref
));
6638 if Typ
/= Standard_Long_Long_Integer
then
6640 -- The context is a specific integer type with which the
6641 -- original attribute was compatible. The function has a
6642 -- specific type as well, so to preserve the compatibility
6643 -- we must convert explicitly.
6645 New_Node
:= Convert_To
(Typ
, New_Node
);
6648 Rewrite
(N
, New_Node
);
6649 Analyze_And_Resolve
(N
, Typ
);
6653 -- Call Expand_Size_Attribute to do the final part of the
6654 -- expansion which is shared with GNATprove expansion.
6656 Expand_Size_Attribute
(N
);
6663 when Attribute_Storage_Size
=> Storage_Size
: declare
6664 Alloc_Op
: Entity_Id
:= Empty
;
6668 -- Access type case, always go to the root type
6670 -- The case of access types results in a value of zero for the case
6671 -- where no storage size attribute clause has been given. If a
6672 -- storage size has been given, then the attribute is converted
6673 -- to a reference to the variable used to hold this value.
6675 if Is_Access_Type
(Ptyp
) then
6676 if Present
(Storage_Size_Variable
(Root_Type
(Ptyp
))) then
6679 Make_Attribute_Reference
(Loc
,
6680 Prefix
=> New_Occurrence_Of
6681 (Etype
(Storage_Size_Variable
(Root_Type
(Ptyp
))), Loc
),
6682 Attribute_Name
=> Name_Max
,
6683 Expressions
=> New_List
(
6684 Make_Integer_Literal
(Loc
, 0),
6686 (Storage_Size_Variable
(Root_Type
(Ptyp
)), Loc
)))));
6688 elsif Present
(Associated_Storage_Pool
(Root_Type
(Ptyp
))) then
6690 -- If the access type is associated with a simple storage pool
6691 -- object, then attempt to locate the optional Storage_Size
6692 -- function of the simple storage pool type. If not found,
6693 -- then the result will default to zero.
6695 if Present
(Get_Rep_Pragma
(Root_Type
(Ptyp
),
6696 Name_Simple_Storage_Pool_Type
))
6699 Pool_Type
: constant Entity_Id
:=
6700 Base_Type
(Etype
(Entity
(N
)));
6703 Alloc_Op
:= Get_Name_Entity_Id
(Name_Storage_Size
);
6704 while Present
(Alloc_Op
) loop
6705 if Scope
(Alloc_Op
) = Scope
(Pool_Type
)
6706 and then Present
(First_Formal
(Alloc_Op
))
6707 and then Etype
(First_Formal
(Alloc_Op
)) = Pool_Type
6712 Alloc_Op
:= Homonym
(Alloc_Op
);
6716 -- In the normal Storage_Pool case, retrieve the primitive
6717 -- function associated with the pool type.
6722 (Etype
(Associated_Storage_Pool
(Root_Type
(Ptyp
))),
6723 Attribute_Name
(N
));
6726 -- If Storage_Size wasn't found (can only occur in the simple
6727 -- storage pool case), then simply use zero for the result.
6729 if No
(Alloc_Op
) then
6730 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6732 -- Otherwise, rewrite the allocator as a call to pool type's
6733 -- Storage_Size function.
6738 Make_Function_Call
(Loc
,
6740 New_Occurrence_Of
(Alloc_Op
, Loc
),
6742 Parameter_Associations
=> New_List
(
6744 (Associated_Storage_Pool
6745 (Root_Type
(Ptyp
)), Loc
)))));
6749 Rewrite
(N
, Make_Integer_Literal
(Loc
, 0));
6752 Analyze_And_Resolve
(N
, Typ
);
6754 -- For tasks, we retrieve the size directly from the TCB. The
6755 -- size may depend on a discriminant of the type, and therefore
6756 -- can be a per-object expression, so type-level information is
6757 -- not sufficient in general. There are four cases to consider:
6759 -- a) If the attribute appears within a task body, the designated
6760 -- TCB is obtained by a call to Self.
6762 -- b) If the prefix of the attribute is the name of a task object,
6763 -- the designated TCB is the one stored in the corresponding record.
6765 -- c) If the prefix is a task type, the size is obtained from the
6766 -- size variable created for each task type
6768 -- d) If no Storage_Size was specified for the type, there is no
6769 -- size variable, and the value is a system-specific default.
6772 if In_Open_Scopes
(Ptyp
) then
6774 -- Storage_Size (Self)
6778 Make_Function_Call
(Loc
,
6780 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6781 Parameter_Associations
=>
6783 Make_Function_Call
(Loc
,
6785 New_Occurrence_Of
(RTE
(RE_Self
), Loc
))))));
6787 elsif not Is_Entity_Name
(Pref
)
6788 or else not Is_Type
(Entity
(Pref
))
6790 -- Storage_Size (Rec (Obj).Size)
6794 Make_Function_Call
(Loc
,
6796 New_Occurrence_Of
(RTE
(RE_Storage_Size
), Loc
),
6797 Parameter_Associations
=>
6799 Make_Selected_Component
(Loc
,
6801 Unchecked_Convert_To
(
6802 Corresponding_Record_Type
(Ptyp
),
6803 New_Copy_Tree
(Pref
)),
6805 Make_Identifier
(Loc
, Name_uTask_Id
))))));
6807 elsif Present
(Storage_Size_Variable
(Ptyp
)) then
6809 -- Static Storage_Size pragma given for type: retrieve value
6810 -- from its allocated storage variable.
6814 Make_Function_Call
(Loc
,
6815 Name
=> New_Occurrence_Of
(
6816 RTE
(RE_Adjust_Storage_Size
), Loc
),
6817 Parameter_Associations
=>
6820 Storage_Size_Variable
(Ptyp
), Loc
)))));
6822 -- Get system default
6826 Make_Function_Call
(Loc
,
6829 RTE
(RE_Default_Stack_Size
), Loc
))));
6832 Analyze_And_Resolve
(N
, Typ
);
6840 when Attribute_Stream_Size
=>
6842 Make_Integer_Literal
(Loc
, Intval
=> Get_Stream_Size
(Ptyp
)));
6843 Analyze_And_Resolve
(N
, Typ
);
6849 -- 1. Deal with enumeration types with holes.
6850 -- 2. For floating-point, generate call to attribute function.
6851 -- 3. For other cases, deal with constraint checking.
6853 when Attribute_Succ
=> Succ
: declare
6854 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
6857 -- For enumeration types with non-standard representations, we
6858 -- expand typ'Pred (x) into:
6860 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6862 -- if the representation is non-contiguous, and just x + 1 if it is
6863 -- after having dealt with constraint checking.
6865 if Is_Enumeration_Type
(Etyp
)
6866 and then Present
(Enum_Pos_To_Rep
(Etyp
))
6868 if Has_Contiguous_Rep
(Etyp
) then
6869 if not Range_Checks_Suppressed
(Ptyp
) then
6870 Set_Do_Range_Check
(First
(Exprs
), False);
6871 Expand_Pred_Succ_Attribute
(N
);
6875 Unchecked_Convert_To
(Etyp
,
6878 Unchecked_Convert_To
(
6880 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
6883 Make_Integer_Literal
(Loc
, 1))));
6886 -- Add Boolean parameter depending on check suppression
6888 Append_To
(Exprs
, Rep_To_Pos_Flag
(Ptyp
, Loc
));
6890 Make_Indexed_Component
(Loc
,
6893 (Enum_Pos_To_Rep
(Etyp
), Loc
),
6894 Expressions
=> New_List
(
6897 Make_Function_Call
(Loc
,
6900 (TSS
(Etyp
, TSS_Rep_To_Pos
), Loc
),
6901 Parameter_Associations
=> Exprs
),
6902 Right_Opnd
=> Make_Integer_Literal
(Loc
, 1)))));
6905 -- Suppress checks since they have all been done above
6907 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
6909 -- For floating-point, we transform 'Succ into a call to the Succ
6910 -- floating-point attribute function in Fat_xxx (xxx is root type).
6911 -- Note that this function takes care of the overflow case.
6913 elsif Is_Floating_Point_Type
(Ptyp
) then
6914 Expand_Fpt_Attribute_R
(N
);
6915 Analyze_And_Resolve
(N
, Typ
);
6917 -- For modular types, nothing to do (no overflow, since wraps)
6919 elsif Is_Modular_Integer_Type
(Ptyp
) then
6922 -- For other types, if argument is marked as needing a range check or
6923 -- overflow checking is enabled, we must generate a check.
6925 elsif not Overflow_Checks_Suppressed
(Ptyp
)
6926 or else Do_Range_Check
(First
(Exprs
))
6928 Set_Do_Range_Check
(First
(Exprs
), False);
6929 Expand_Pred_Succ_Attribute
(N
);
6937 -- Transforms X'Tag into a direct reference to the tag of X
6939 when Attribute_Tag
=> Tag
: declare
6941 Prefix_Is_Type
: Boolean;
6944 if Is_Entity_Name
(Pref
) and then Is_Type
(Entity
(Pref
)) then
6945 Ttyp
:= Entity
(Pref
);
6946 Prefix_Is_Type
:= True;
6949 Prefix_Is_Type
:= False;
6952 -- In the case of a class-wide equivalent type without a parent,
6953 -- the _Tag component has been built in Make_CW_Equivalent_Type
6954 -- manually and must be referenced directly.
6956 if Ekind
(Ttyp
) = E_Class_Wide_Subtype
6957 and then Present
(Equivalent_Type
(Ttyp
))
6958 and then No
(Parent_Subtype
(Equivalent_Type
(Ttyp
)))
6960 Ttyp
:= Equivalent_Type
(Ttyp
);
6962 -- In all the other cases of class-wide type, including an equivalent
6963 -- type with a parent, the _Tag component ultimately present is that
6964 -- of the root type.
6966 elsif Is_Class_Wide_Type
(Ttyp
) then
6967 Ttyp
:= Root_Type
(Ttyp
);
6970 Ttyp
:= Underlying_Type
(Ttyp
);
6972 -- Ada 2005: The type may be a synchronized tagged type, in which
6973 -- case the tag information is stored in the corresponding record.
6975 if Is_Concurrent_Type
(Ttyp
) then
6976 Ttyp
:= Corresponding_Record_Type
(Ttyp
);
6979 if Prefix_Is_Type
then
6981 -- For VMs we leave the type attribute unexpanded because
6982 -- there's not a dispatching table to reference.
6984 if Tagged_Type_Expansion
then
6986 Unchecked_Convert_To
(RTE
(RE_Tag
),
6988 (Node
(First_Elmt
(Access_Disp_Table
(Ttyp
))), Loc
)));
6989 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
6992 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6993 -- references the primary tag of the actual object. If 'Tag is
6994 -- applied to class-wide interface objects we generate code that
6995 -- displaces "this" to reference the base of the object.
6997 elsif Comes_From_Source
(N
)
6998 and then Is_Class_Wide_Type
(Etype
(Prefix
(N
)))
6999 and then Is_Interface
(Underlying_Type
(Etype
(Prefix
(N
))))
7002 -- (To_Tag_Ptr (Prefix'Address)).all
7004 -- Note that Prefix'Address is recursively expanded into a call
7005 -- to Base_Address (Obj.Tag)
7007 -- Not needed for VM targets, since all handled by the VM
7009 if Tagged_Type_Expansion
then
7011 Make_Explicit_Dereference
(Loc
,
7012 Unchecked_Convert_To
(RTE
(RE_Tag_Ptr
),
7013 Make_Attribute_Reference
(Loc
,
7014 Prefix
=> Relocate_Node
(Pref
),
7015 Attribute_Name
=> Name_Address
))));
7016 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
7021 Make_Selected_Component
(Loc
,
7022 Prefix
=> Relocate_Node
(Pref
),
7024 New_Occurrence_Of
(First_Tag_Component
(Ttyp
), Loc
)));
7025 Analyze_And_Resolve
(N
, RTE
(RE_Tag
));
7033 -- Transforms 'Terminated attribute into a call to Terminated function
7035 when Attribute_Terminated
=> Terminated
: begin
7037 -- The prefix of Terminated is of a task interface class-wide type.
7039 -- terminated (Task_Id (_disp_get_task_id (Pref)));
7041 if Ada_Version
>= Ada_2005
7042 and then Ekind
(Ptyp
) = E_Class_Wide_Type
7043 and then Is_Interface
(Ptyp
)
7044 and then Is_Task_Interface
(Ptyp
)
7047 Make_Function_Call
(Loc
,
7049 New_Occurrence_Of
(RTE
(RE_Terminated
), Loc
),
7050 Parameter_Associations
=> New_List
(
7051 Unchecked_Convert_To
7052 (RTE
(RO_ST_Task_Id
),
7053 Build_Disp_Get_Task_Id_Call
(Pref
)))));
7055 elsif Restricted_Profile
then
7057 Build_Call_With_Task
(Pref
, RTE
(RE_Restricted_Terminated
)));
7061 Build_Call_With_Task
(Pref
, RTE
(RE_Terminated
)));
7064 Analyze_And_Resolve
(N
, Standard_Boolean
);
7071 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
7072 -- unchecked conversion from (integral) type of X to type address. If
7073 -- the To_Address is a static expression, the transformed expression
7074 -- also needs to be static, because we do some legality checks (e.g.
7075 -- for Thread_Local_Storage) after this transformation.
7078 | Attribute_To_Address
7080 To_Address
: declare
7081 Is_Static
: constant Boolean := Is_Static_Expression
(N
);
7085 Unchecked_Convert_To
(RTE
(RE_Address
),
7086 Relocate_Node
(First
(Exprs
))));
7087 Set_Is_Static_Expression
(N
, Is_Static
);
7089 Analyze_And_Resolve
(N
, RTE
(RE_Address
));
7096 when Attribute_To_Any
=> To_Any
: declare
7097 Decls
: constant List_Id
:= New_List
;
7103 Relocate_Node
(First
(Exprs
))), Decls
));
7104 Insert_Actions
(N
, Decls
);
7105 Analyze_And_Resolve
(N
, RTE
(RE_Any
));
7112 -- Transforms 'Truncation into a call to the floating-point attribute
7113 -- function Truncation in Fat_xxx (where xxx is the root type).
7114 -- Expansion is avoided for cases the back end can handle directly.
7116 when Attribute_Truncation
=>
7117 if not Is_Inline_Floating_Point_Attribute
(N
) then
7118 Expand_Fpt_Attribute_R
(N
);
7125 when Attribute_TypeCode
=> TypeCode
: declare
7126 Decls
: constant List_Id
:= New_List
;
7128 Rewrite
(N
, Build_TypeCode_Call
(Loc
, Ptyp
, Decls
));
7129 Insert_Actions
(N
, Decls
);
7130 Analyze_And_Resolve
(N
, RTE
(RE_TypeCode
));
7133 -----------------------
7134 -- Unbiased_Rounding --
7135 -----------------------
7137 -- Transforms 'Unbiased_Rounding into a call to the floating-point
7138 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
7139 -- root type). Expansion is avoided for cases the back end can handle
7142 when Attribute_Unbiased_Rounding
=>
7143 if not Is_Inline_Floating_Point_Attribute
(N
) then
7144 Expand_Fpt_Attribute_R
(N
);
7151 when Attribute_Update
=>
7152 Expand_Update_Attribute
(N
);
7158 -- The processing for VADS_Size is shared with Size
7164 -- For enumeration types with a non-standard representation we use the
7165 -- _Pos_To_Rep array that was created when the type was frozen, unless
7166 -- the representation is contiguous in which case we use an addition.
7168 -- For enumeration types with a standard representation, Val can be
7169 -- rewritten as a simple conversion with Conversion_OK set.
7171 -- For integer types, Val is equivalent to a simple integer conversion
7172 -- and we rewrite it as such.
7174 when Attribute_Val
=> Val
: declare
7175 Etyp
: constant Entity_Id
:= Base_Type
(Ptyp
);
7176 Expr
: constant Node_Id
:= First
(Exprs
);
7180 -- Case of enumeration type
7182 if Is_Enumeration_Type
(Etyp
) then
7184 -- Non-contiguous non-standard enumeration type
7186 if Present
(Enum_Pos_To_Rep
(Etyp
))
7187 and then not Has_Contiguous_Rep
(Etyp
)
7190 Make_Indexed_Component
(Loc
,
7192 New_Occurrence_Of
(Enum_Pos_To_Rep
(Etyp
), Loc
),
7193 Expressions
=> New_List
(
7194 Convert_To
(Standard_Integer
, Expr
))));
7196 Analyze_And_Resolve
(N
, Typ
);
7198 -- Standard or contiguous non-standard enumeration type
7201 -- If the argument is marked as requiring a range check then
7202 -- generate it here, after looking through a conversion to
7203 -- universal integer, if any.
7205 if Do_Range_Check
(Expr
) then
7206 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7207 Rtyp
:= Enum_Pos_To_Rep
(Etyp
);
7212 if Nkind
(Expr
) = N_Type_Conversion
7213 and then Entity
(Subtype_Mark
(Expr
)) = Universal_Integer
7215 Generate_Range_Check
7216 (Expression
(Expr
), Rtyp
, CE_Range_Check_Failed
);
7219 Generate_Range_Check
(Expr
, Rtyp
, CE_Range_Check_Failed
);
7222 Set_Do_Range_Check
(Expr
, False);
7225 -- Contiguous non-standard enumeration type
7227 if Present
(Enum_Pos_To_Rep
(Etyp
)) then
7229 Unchecked_Convert_To
(Etyp
,
7232 Make_Integer_Literal
(Loc
,
7233 Enumeration_Rep
(First_Literal
(Etyp
))),
7235 Unchecked_Convert_To
(
7237 (Esize
(Etyp
), Is_Unsigned_Type
(Etyp
)),
7240 -- Standard enumeration type
7243 Rewrite
(N
, OK_Convert_To
(Typ
, Expr
));
7246 -- Suppress checks since the range check was done above
7247 -- and it guarantees that the addition cannot overflow.
7249 Analyze_And_Resolve
(N
, Typ
, Suppress
=> All_Checks
);
7252 -- Deal with integer types
7254 elsif Is_Integer_Type
(Etyp
) then
7255 Rewrite
(N
, Convert_To
(Typ
, Expr
));
7256 Analyze_And_Resolve
(N
, Typ
);
7264 -- The code for valid is dependent on the particular types involved.
7265 -- See separate sections below for the generated code in each case.
7267 when Attribute_Valid
=> Valid
: declare
7268 PBtyp
: Entity_Id
:= Implementation_Base_Type
(Validated_View
(Ptyp
));
7269 pragma Assert
(Is_Scalar_Type
(PBtyp
)
7270 or else Serious_Errors_Detected
> 0);
7272 -- The scalar base type, looking through private types
7274 Save_Validity_Checks_On
: constant Boolean := Validity_Checks_On
;
7275 -- Save the validity checking mode. We always turn off validity
7276 -- checking during process of 'Valid since this is one place
7277 -- where we do not want the implicit validity checks to interfere
7278 -- with the explicit validity check that the programmer is doing.
7280 function Make_Range_Test
return Node_Id
;
7281 -- Build the code for a range test of the form
7282 -- PBtyp!(Pref) in PBtyp!(Ptyp'First) .. PBtyp!(Ptyp'Last)
7284 ---------------------
7285 -- Make_Range_Test --
7286 ---------------------
7288 function Make_Range_Test
return Node_Id
is
7292 -- The prefix of attribute 'Valid should always denote an object
7293 -- reference. The reference is either coming directly from source
7294 -- or is produced by validity check expansion. The object may be
7295 -- wrapped in a conversion in which case the call to Unqual_Conv
7298 -- If the prefix denotes a variable which captures the value of
7299 -- an object for validation purposes, use the variable in the
7300 -- range test. This ensures that no extra copies or extra reads
7301 -- are produced as part of the test. Generate:
7303 -- Temp : ... := Object;
7304 -- if not Temp in ... then
7306 if Is_Validation_Variable_Reference
(Pref
) then
7307 Temp
:= New_Occurrence_Of
(Entity
(Unqual_Conv
(Pref
)), Loc
);
7309 -- Otherwise the prefix is either a source object or a constant
7310 -- produced by validity check expansion. Generate:
7312 -- Temp : constant ... := Pref;
7313 -- if not Temp in ... then
7316 Temp
:= Duplicate_Subexpr
(Pref
);
7320 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7324 Left_Opnd
=> Unchecked_Convert_To
(PBtyp
, Temp
),
7328 Unchecked_Convert_To
(PBtyp
,
7329 Make_Attribute_Reference
(Loc
,
7331 New_Occurrence_Of
(Val_Typ
, Loc
),
7332 Attribute_Name
=> Name_First
)),
7334 Unchecked_Convert_To
(PBtyp
,
7335 Make_Attribute_Reference
(Loc
,
7337 New_Occurrence_Of
(Val_Typ
, Loc
),
7338 Attribute_Name
=> Name_Last
))));
7340 end Make_Range_Test
;
7346 -- Start of processing for Attribute_Valid
7349 -- Do not expand sourced code 'Valid reference in CodePeer mode,
7350 -- will be handled by the back-end directly.
7352 if CodePeer_Mode
and then Comes_From_Source
(N
) then
7356 -- Turn off validity checks. We do not want any implicit validity
7357 -- checks to intefere with the explicit check from the attribute
7359 Validity_Checks_On
:= False;
7361 -- Floating-point case. This case is handled by the Valid attribute
7362 -- code in the floating-point attribute run-time library.
7364 if Is_Floating_Point_Type
(Ptyp
) then
7365 Float_Valid
: declare
7369 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
;
7370 -- Return entity for Pkg.Nam
7372 --------------------
7373 -- Get_Fat_Entity --
7374 --------------------
7376 function Get_Fat_Entity
(Nam
: Name_Id
) return Entity_Id
is
7377 Exp_Name
: constant Node_Id
:=
7378 Make_Selected_Component
(Loc
,
7379 Prefix
=> New_Occurrence_Of
(RTE
(Pkg
), Loc
),
7380 Selector_Name
=> Make_Identifier
(Loc
, Nam
));
7382 Find_Selected_Component
(Exp_Name
);
7383 return Entity
(Exp_Name
);
7386 -- Start of processing for Float_Valid
7389 -- The C back end handles Valid for floating-point types
7391 if Modify_Tree_For_C
then
7392 Analyze_And_Resolve
(Pref
, Ptyp
);
7393 Set_Etype
(N
, Standard_Boolean
);
7397 Find_Fat_Info
(Ptyp
, Ftp
, Pkg
);
7399 -- If the prefix is a reverse SSO component, or is possibly
7400 -- unaligned, first create a temporary copy that is in
7401 -- native SSO, and properly aligned. Make it Volatile to
7402 -- prevent folding in the back-end. Note that we use an
7403 -- intermediate constrained string type to initialize the
7404 -- temporary, as the value at hand might be invalid, and in
7405 -- that case it cannot be copied using a floating point
7408 if In_Reverse_Storage_Order_Object
(Pref
)
7409 or else Is_Possibly_Unaligned_Object
(Pref
)
7412 Temp
: constant Entity_Id
:=
7413 Make_Temporary
(Loc
, 'F');
7415 Fat_S
: constant Entity_Id
:=
7416 Get_Fat_Entity
(Name_S
);
7417 -- Constrained string subtype of appropriate size
7419 Fat_P
: constant Entity_Id
:=
7420 Get_Fat_Entity
(Name_P
);
7423 Decl
: constant Node_Id
:=
7424 Make_Object_Declaration
(Loc
,
7425 Defining_Identifier
=> Temp
,
7426 Aliased_Present
=> True,
7427 Object_Definition
=>
7428 New_Occurrence_Of
(Ptyp
, Loc
));
7431 Set_Aspect_Specifications
(Decl
, New_List
(
7432 Make_Aspect_Specification
(Loc
,
7434 Make_Identifier
(Loc
, Name_Volatile
))));
7440 Make_Assignment_Statement
(Loc
,
7442 Make_Explicit_Dereference
(Loc
,
7444 Unchecked_Convert_To
(Fat_P
,
7445 Make_Attribute_Reference
(Loc
,
7447 New_Occurrence_Of
(Temp
, Loc
),
7449 Name_Unrestricted_Access
))),
7451 Unchecked_Convert_To
(Fat_S
,
7452 Relocate_Node
(Pref
)))),
7454 Suppress
=> All_Checks
);
7456 Rewrite
(Pref
, New_Occurrence_Of
(Temp
, Loc
));
7460 -- We now have an object of the proper endianness and
7461 -- alignment, and can construct a Valid attribute.
7463 -- We make sure the prefix of this valid attribute is
7464 -- marked as not coming from source, to avoid losing
7465 -- warnings from 'Valid looking like a possible update.
7467 Set_Comes_From_Source
(Pref
, False);
7469 Expand_Fpt_Attribute
7470 (N
, Pkg
, Name_Valid
,
7472 Make_Attribute_Reference
(Loc
,
7473 Prefix
=> Unchecked_Convert_To
(Ftp
, Pref
),
7474 Attribute_Name
=> Name_Unrestricted_Access
)));
7477 -- One more task, we still need a range check. Required
7478 -- only if we have a constraint, since the Valid routine
7479 -- catches infinities properly (infinities are never valid).
7481 -- The way we do the range check is simply to create the
7482 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
7484 if not Subtypes_Statically_Match
(Ptyp
, PBtyp
) then
7487 Left_Opnd
=> Relocate_Node
(N
),
7490 Left_Opnd
=> Convert_To
(PBtyp
, Pref
),
7491 Right_Opnd
=> New_Occurrence_Of
(Ptyp
, Loc
))));
7495 -- Enumeration type with holes
7497 -- For enumeration types with holes, the Pos value constructed by
7498 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
7499 -- second argument of False returns minus one for an invalid value,
7500 -- and the non-negative pos value for a valid value, so the
7501 -- expansion of X'Valid is simply:
7503 -- type(X)'Pos (X) >= 0
7505 -- We can't quite generate it that way because of the requirement
7506 -- for the non-standard second argument of False in the resulting
7507 -- rep_to_pos call, so we have to explicitly create:
7509 -- _rep_to_pos (X, False) >= 0
7511 -- If we have an enumeration subtype, we also check that the
7512 -- value is in range:
7514 -- _rep_to_pos (X, False) >= 0
7516 -- (X >= type(X)'First and then type(X)'Last <= X)
7518 elsif Is_Enumeration_Type
(Ptyp
)
7519 and then Present
(Enum_Pos_To_Rep
(PBtyp
))
7524 Make_Function_Call
(Loc
,
7526 New_Occurrence_Of
(TSS
(PBtyp
, TSS_Rep_To_Pos
), Loc
),
7527 Parameter_Associations
=> New_List
(
7529 New_Occurrence_Of
(Standard_False
, Loc
))),
7530 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0));
7532 -- Skip the range test for boolean types, as it buys us
7533 -- nothing. The function called above already fails for
7534 -- values different from both True and False.
7536 if Ptyp
/= PBtyp
and then not Is_Boolean_Type
(PBtyp
)
7538 (Type_Low_Bound
(Ptyp
) /= Type_Low_Bound
(PBtyp
)
7540 Type_High_Bound
(Ptyp
) /= Type_High_Bound
(PBtyp
))
7542 -- The call to Make_Range_Test will create declarations
7543 -- that need a proper insertion point, but Pref is now
7544 -- attached to a node with no ancestor. Attach to tree
7545 -- even if it is to be rewritten below.
7547 Set_Parent
(Tst
, Parent
(N
));
7551 Left_Opnd
=> Make_Range_Test
,
7557 -- Fortran convention booleans
7559 -- For the very special case of Fortran convention booleans, the
7560 -- value is always valid, since it is an integer with the semantics
7561 -- that non-zero is true, and any value is permissible.
7563 elsif Is_Boolean_Type
(Ptyp
)
7564 and then Convention
(Ptyp
) = Convention_Fortran
7566 Rewrite
(N
, New_Occurrence_Of
(Standard_True
, Loc
));
7568 -- For biased representations, we will be doing an unchecked
7569 -- conversion without unbiasing the result. That means that the range
7570 -- test has to take this into account, and the proper form of the
7573 -- PBtyp!(Pref) < PBtyp!(Ptyp'Range_Length)
7575 elsif Has_Biased_Representation
(Ptyp
) then
7576 PBtyp
:= RTE
(RE_Unsigned_32
);
7580 Unchecked_Convert_To
(PBtyp
, Duplicate_Subexpr
(Pref
)),
7582 Unchecked_Convert_To
(PBtyp
,
7583 Make_Attribute_Reference
(Loc
,
7584 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
7585 Attribute_Name
=> Name_Range_Length
))));
7587 -- For all other scalar types, what we want logically is a
7590 -- X in type(X)'First .. type(X)'Last
7592 -- But that's precisely what won't work because of possible
7593 -- unwanted optimization (and indeed the basic motivation for
7594 -- the Valid attribute is exactly that this test does not work).
7595 -- What will work is:
7597 -- PBtyp!(X) >= PBtyp!(type(X)'First)
7599 -- PBtyp!(X) <= PBtyp!(type(X)'Last)
7601 -- where PBtyp is an integer type large enough to cover the full
7602 -- range of possible stored values (i.e. it is chosen on the basis
7603 -- of the size of the type, not the range of the values). We write
7604 -- this as two tests, rather than a range check, so that static
7605 -- evaluation will easily remove either or both of the checks if
7606 -- they can be statically determined to be true (this happens
7607 -- when the type of X is static and the range extends to the full
7608 -- range of stored values).
7610 -- Unsigned types. Note: it is safe to consider only whether the
7611 -- subtype is unsigned, since we will in that case be doing all
7612 -- unsigned comparisons based on the subtype range. Since we use the
7613 -- actual subtype object size, this is appropriate.
7615 -- For example, if we have
7617 -- subtype x is integer range 1 .. 200;
7618 -- for x'Object_Size use 8;
7620 -- Now the base type is signed, but objects of this type are bits
7621 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7622 -- correct, even though a value greater than 127 looks signed to a
7623 -- signed comparison.
7627 Uns
: constant Boolean :=
7628 Is_Unsigned_Type
(Ptyp
)
7629 or else (Is_Private_Type
(Ptyp
)
7630 and then Is_Unsigned_Type
(PBtyp
));
7632 P
: Node_Id
:= Pref
;
7635 -- If the prefix is an object, use the Esize from this object
7636 -- to handle in a more user friendly way the case of objects
7637 -- or components with a large Size aspect: if a Size aspect is
7638 -- specified, we want to read a scalar value as large as the
7639 -- Size, unless the Size is larger than
7640 -- System_Max_Integer_Size.
7642 if Nkind
(P
) = N_Selected_Component
then
7643 P
:= Selector_Name
(P
);
7646 if Nkind
(P
) in N_Has_Entity
7647 and then Present
(Entity
(P
))
7648 and then Is_Object
(Entity
(P
))
7649 and then Known_Esize
(Entity
(P
))
7651 if Esize
(Entity
(P
)) <= System_Max_Integer_Size
then
7652 Size
:= Esize
(Entity
(P
));
7654 Size
:= UI_From_Int
(System_Max_Integer_Size
);
7657 Size
:= Esize
(Ptyp
);
7660 PBtyp
:= Small_Integer_Type_For
(Size
, Uns
);
7661 Rewrite
(N
, Make_Range_Test
);
7665 -- If a predicate is present, then we do the predicate test, even if
7666 -- within the predicate function (infinite recursion is warned about
7667 -- in Sem_Attr in that case).
7670 Pred_Func
: constant Entity_Id
:= Predicate_Function
(Ptyp
);
7673 if Present
(Pred_Func
) then
7676 Left_Opnd
=> Relocate_Node
(N
),
7677 Right_Opnd
=> Make_Predicate_Call
(Ptyp
, Pref
)));
7681 Analyze_And_Resolve
(N
, Standard_Boolean
);
7682 Validity_Checks_On
:= Save_Validity_Checks_On
;
7689 when Attribute_Valid_Value
=>
7690 Exp_Imgv
.Expand_Valid_Value_Attribute
(N
);
7696 when Attribute_Valid_Scalars
=> Valid_Scalars
: declare
7697 Val_Typ
: constant Entity_Id
:= Validated_View
(Ptyp
);
7701 -- Assume that the prefix does not need validation
7705 -- Attribute 'Valid_Scalars is not supported on private tagged types;
7706 -- see a detailed explanation where this attribute is analyzed.
7708 if Is_Private_Type
(Ptyp
) and then Is_Tagged_Type
(Ptyp
) then
7711 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7714 elsif not Scalar_Part_Present
(Val_Typ
) then
7717 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7718 -- validated type is a scalar type. Generate:
7720 -- Val_Typ (Pref)'Valid
7722 elsif Is_Scalar_Type
(Val_Typ
) then
7724 Make_Attribute_Reference
(Loc
,
7726 Unchecked_Convert_To
(Val_Typ
, New_Copy_Tree
(Pref
)),
7727 Attribute_Name
=> Name_Valid
);
7729 -- Required by LLVM although the sizes are the same???
7731 if Nkind
(Prefix
(Expr
)) = N_Unchecked_Type_Conversion
then
7732 Set_No_Truncation
(Prefix
(Expr
));
7735 -- Validate the scalar components of an array by iterating over all
7736 -- dimensions of the array while checking individual components.
7738 elsif Is_Array_Type
(Val_Typ
) then
7740 Make_Function_Call
(Loc
,
7743 (Build_Array_VS_Func
7746 Array_Typ
=> Val_Typ
),
7748 Parameter_Associations
=> New_List
(Pref
));
7750 -- Validate the scalar components, discriminants of a record type by
7751 -- examining the structure of a record type.
7753 elsif Is_Record_Type
(Val_Typ
) then
7755 Make_Function_Call
(Loc
,
7758 (Build_Record_VS_Func
7761 Rec_Typ
=> Val_Typ
),
7763 Parameter_Associations
=> New_List
(Pref
));
7766 -- Default the attribute to True when the type of the prefix does not
7770 Expr
:= New_Occurrence_Of
(Standard_True
, Loc
);
7774 Analyze_And_Resolve
(N
, Standard_Boolean
);
7775 Set_Is_Static_Expression
(N
, False);
7782 when Attribute_Value
=>
7783 Exp_Imgv
.Expand_Value_Attribute
(N
);
7789 -- The processing for Value_Size shares the processing for Size
7795 -- The processing for Version shares the processing for Body_Version
7801 when Attribute_Wide_Image
=>
7802 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7803 -- back-end knows how to handle this attribute directly.
7805 if CodePeer_Mode
then
7809 Exp_Imgv
.Expand_Wide_Image_Attribute
(N
);
7811 ---------------------
7812 -- Wide_Wide_Image --
7813 ---------------------
7815 when Attribute_Wide_Wide_Image
=>
7816 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7817 -- back-end knows how to handle this attribute directly.
7819 if CodePeer_Mode
then
7823 Exp_Imgv
.Expand_Wide_Wide_Image_Attribute
(N
);
7829 -- We expand typ'Wide_Value (X) into
7832 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7834 -- Wide_String_To_String is a runtime function that converts its wide
7835 -- string argument to String, converting any non-translatable characters
7836 -- into appropriate escape sequences. This preserves the required
7837 -- semantics of Wide_Value in all cases, and results in a very simple
7838 -- implementation approach.
7840 -- Note: for this approach to be fully standard compliant for the cases
7841 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7842 -- method must cover the entire character range (e.g. UTF-8). But that
7843 -- is a reasonable requirement when dealing with encoded character
7844 -- sequences. Presumably if one of the restrictive encoding mechanisms
7845 -- is in use such as Shift-JIS, then characters that cannot be
7846 -- represented using this encoding will not appear in any case.
7848 when Attribute_Wide_Value
=>
7850 Make_Attribute_Reference
(Loc
,
7852 Attribute_Name
=> Name_Value
,
7854 Expressions
=> New_List
(
7855 Make_Function_Call
(Loc
,
7857 New_Occurrence_Of
(RTE
(RE_Wide_String_To_String
), Loc
),
7859 Parameter_Associations
=> New_List
(
7860 Relocate_Node
(First
(Exprs
)),
7861 Make_Integer_Literal
(Loc
,
7862 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7864 Analyze_And_Resolve
(N
, Typ
);
7866 ---------------------
7867 -- Wide_Wide_Value --
7868 ---------------------
7870 -- We expand typ'Wide_Value_Value (X) into
7873 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7875 -- See Wide_Value for more information. This is not quite right where
7876 -- typ = Wide_Wide_Character, because the encoding method may not cover
7877 -- the whole character type.
7879 when Attribute_Wide_Wide_Value
=>
7881 Make_Attribute_Reference
(Loc
,
7883 Attribute_Name
=> Name_Value
,
7885 Expressions
=> New_List
(
7886 Make_Function_Call
(Loc
,
7889 (RTE
(RE_Wide_Wide_String_To_String
), Loc
),
7891 Parameter_Associations
=> New_List
(
7892 Relocate_Node
(First
(Exprs
)),
7893 Make_Integer_Literal
(Loc
,
7894 Intval
=> Int
(Wide_Character_Encoding_Method
)))))));
7896 Analyze_And_Resolve
(N
, Typ
);
7898 ---------------------
7899 -- Wide_Wide_Width --
7900 ---------------------
7902 when Attribute_Wide_Wide_Width
=>
7903 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide_Wide
);
7909 when Attribute_Wide_Width
=>
7910 Exp_Imgv
.Expand_Width_Attribute
(N
, Wide
);
7916 when Attribute_Width
=>
7917 Exp_Imgv
.Expand_Width_Attribute
(N
, Normal
);
7923 when Attribute_Write
=> Write
: declare
7924 P_Type
: constant Entity_Id
:= Entity
(Pref
);
7925 U_Type
: constant Entity_Id
:= Underlying_Type
(P_Type
);
7926 Has_TSS
: Boolean := False;
7934 -- If no underlying type, we have an error that will be diagnosed
7935 -- elsewhere, so here we just completely ignore the expansion.
7941 -- Stream operations can appear in user code even if the restriction
7942 -- No_Streams is active (for example, when instantiating a predefined
7943 -- container). In that case rewrite the attribute as a Raise to
7944 -- prevent any run-time use.
7946 if Restriction_Active
(No_Streams
) then
7948 Make_Raise_Program_Error
(Sloc
(N
),
7949 Reason
=> PE_Stream_Operation_Not_Allowed
));
7950 Set_Etype
(N
, U_Type
);
7954 -- The simple case, if there is a TSS for Write, just call it
7956 Pname
:= Find_Stream_Subprogram
(P_Type
, TSS_Stream_Write
, N
);
7958 if Present
(Pname
) then
7962 -- If there is a Stream_Convert pragma, use it, we rewrite
7964 -- sourcetyp'Output (stream, Item)
7968 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7970 -- where strmwrite is the given Write function that converts an
7971 -- argument of type sourcetyp or a type acctyp, from which it is
7972 -- derived to type strmtyp. The conversion to acttyp is required
7973 -- for the derived case.
7975 Prag
:= Get_Stream_Convert_Pragma
(P_Type
);
7977 if Present
(Prag
) then
7979 Next
(Next
(First
(Pragma_Argument_Associations
(Prag
))));
7980 Wfunc
:= Entity
(Expression
(Arg3
));
7983 Make_Attribute_Reference
(Loc
,
7984 Prefix
=> New_Occurrence_Of
(Etype
(Wfunc
), Loc
),
7985 Attribute_Name
=> Name_Output
,
7986 Expressions
=> New_List
(
7987 Relocate_Node
(First
(Exprs
)),
7988 Make_Function_Call
(Loc
,
7989 Name
=> New_Occurrence_Of
(Wfunc
, Loc
),
7990 Parameter_Associations
=> New_List
(
7991 OK_Convert_To
(Etype
(First_Formal
(Wfunc
)),
7992 Relocate_Node
(Next
(First
(Exprs
)))))))));
7999 elsif Default_Streaming_Unavailable
(U_Type
) then
8000 -- Do the same thing here as is done above in the
8001 -- case where a No_Streams restriction is active.
8004 Make_Raise_Program_Error
(Sloc
(N
),
8005 Reason
=> PE_Stream_Operation_Not_Allowed
));
8006 Set_Etype
(N
, U_Type
);
8009 -- For elementary types, we call the W_xxx routine directly
8011 elsif Is_Elementary_Type
(U_Type
) then
8012 Rewrite
(N
, Build_Elementary_Write_Call
(N
));
8018 elsif Is_Array_Type
(U_Type
) then
8019 Build_Array_Write_Procedure
(U_Type
, Decl
, Pname
);
8020 Compile_Stream_Body_In_Scope
(N
, Decl
, U_Type
);
8022 -- Tagged type case, use the primitive Write function. Note that
8023 -- this will dispatch in the class-wide case which is what we want
8025 elsif Is_Tagged_Type
(U_Type
) then
8026 Pname
:= Find_Prim_Op
(U_Type
, TSS_Stream_Write
);
8028 -- All other record type cases, including protected records.
8029 -- The latter only arise for expander generated code for
8030 -- handling shared passive partition access.
8034 (Is_Record_Type
(U_Type
) or else Is_Protected_Type
(U_Type
));
8036 -- Ada 2005 (AI-216): Program_Error is raised when executing
8037 -- the default implementation of the Write attribute of an
8038 -- Unchecked_Union type. However, if the 'Write reference is
8039 -- within the generated Output stream procedure, Write outputs
8040 -- the components, and the default values of the discriminant
8041 -- are streamed by the Output procedure itself. If there are
8042 -- no default values this is also erroneous.
8044 if Is_Unchecked_Union
(Base_Type
(U_Type
)) then
8045 if (not Is_TSS
(Current_Scope
, TSS_Stream_Output
)
8046 and not Is_TSS
(Current_Scope
, TSS_Stream_Write
))
8047 or else No
(Discriminant_Default_Value
8048 (First_Discriminant
(U_Type
)))
8051 Make_Raise_Program_Error
(Loc
,
8052 Reason
=> PE_Unchecked_Union_Restriction
));
8053 Set_Etype
(N
, U_Type
);
8058 if Has_Defaulted_Discriminants
(U_Type
) then
8059 Build_Mutable_Record_Write_Procedure
8060 (Full_Base
(U_Type
), Decl
, Pname
);
8062 Build_Record_Write_Procedure
8063 (Full_Base
(U_Type
), Decl
, Pname
);
8066 Insert_Action
(N
, Decl
);
8070 -- If we fall through, Pname is the procedure to be called
8072 Rewrite_Attribute_Proc_Call
(Pname
);
8075 Cached_Streaming_Ops
.Write_Map
.Set
(P_Type
, Pname
);
8079 -- The following attributes are handled by the back end (except that
8080 -- static cases have already been evaluated during semantic processing,
8081 -- but in any case the back end should not count on this).
8083 when Attribute_Code_Address
8085 | Attribute_Null_Parameter
8086 | Attribute_Passed_By_Reference
8087 | Attribute_Pool_Address
8091 -- The following attributes should not appear at this stage, since they
8092 -- have already been handled by the analyzer (and properly rewritten
8093 -- with corresponding values or entities to represent the right values).
8095 when Attribute_Abort_Signal
8096 | Attribute_Address_Size
8098 | Attribute_Atomic_Always_Lock_Free
8100 | Attribute_Bit_Order
8102 | Attribute_Compiler_Version
8103 | Attribute_Default_Bit_Order
8104 | Attribute_Default_Scalar_Storage_Order
8105 | Attribute_Definite
8112 | Attribute_Fast_Math
8113 | Attribute_First_Valid
8114 | Attribute_Has_Access_Values
8115 | Attribute_Has_Discriminants
8116 | Attribute_Has_Tagged_Values
8118 | Attribute_Last_Valid
8119 | Attribute_Library_Level
8120 | Attribute_Machine_Emax
8121 | Attribute_Machine_Emin
8122 | Attribute_Machine_Mantissa
8123 | Attribute_Machine_Overflows
8124 | Attribute_Machine_Radix
8125 | Attribute_Machine_Rounds
8126 | Attribute_Max_Alignment_For_Allocation
8127 | Attribute_Max_Integer_Size
8128 | Attribute_Maximum_Alignment
8129 | Attribute_Model_Emin
8130 | Attribute_Model_Epsilon
8131 | Attribute_Model_Mantissa
8132 | Attribute_Model_Small
8134 | Attribute_Partition_ID
8136 | Attribute_Restriction_Set
8137 | Attribute_Safe_Emax
8138 | Attribute_Safe_First
8139 | Attribute_Safe_Large
8140 | Attribute_Safe_Last
8141 | Attribute_Safe_Small
8142 | Attribute_Scalar_Storage_Order
8144 | Attribute_Signed_Zeros
8146 | Attribute_Small_Denominator
8147 | Attribute_Small_Numerator
8148 | Attribute_Storage_Unit
8149 | Attribute_Stub_Type
8150 | Attribute_System_Allocator_Alignment
8151 | Attribute_Target_Name
8152 | Attribute_Type_Class
8153 | Attribute_Type_Key
8154 | Attribute_Unconstrained_Array
8155 | Attribute_Universal_Literal_String
8156 | Attribute_Wchar_T_Size
8157 | Attribute_Word_Size
8159 raise Program_Error
;
8162 -- Note: as mentioned earlier, individual sections of the above case
8163 -- statement assume there is no code after the case statement, and are
8164 -- legitimately allowed to execute return statements if they have nothing
8165 -- more to do, so DO NOT add code at this point.
8168 when RE_Not_Available
=>
8170 end Expand_N_Attribute_Reference
;
8172 --------------------------------
8173 -- Expand_Pred_Succ_Attribute --
8174 --------------------------------
8176 -- For typ'Pred (exp), we generate the check
8178 -- [constraint_error when exp = typ'Base'First]
8180 -- Similarly, for typ'Succ (exp), we generate the check
8182 -- [constraint_error when exp = typ'Base'Last]
8184 -- These checks are not generated for modular types, since the proper
8185 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
8186 -- We also suppress these checks if we are the right side of an assignment
8187 -- statement or the expression of an object declaration, where the flag
8188 -- Suppress_Assignment_Checks is set for the assignment/declaration.
8190 procedure Expand_Pred_Succ_Attribute
(N
: Node_Id
) is
8191 Loc
: constant Source_Ptr
:= Sloc
(N
);
8192 P
: constant Node_Id
:= Parent
(N
);
8196 if Attribute_Name
(N
) = Name_Pred
then
8202 if Nkind
(P
) not in N_Assignment_Statement | N_Object_Declaration
8203 or else not Suppress_Assignment_Checks
(P
)
8206 Make_Raise_Constraint_Error
(Loc
,
8210 Duplicate_Subexpr_Move_Checks
(First
(Expressions
(N
))),
8212 Make_Attribute_Reference
(Loc
,
8214 New_Occurrence_Of
(Base_Type
(Etype
(Prefix
(N
))), Loc
),
8215 Attribute_Name
=> Cnam
)),
8216 Reason
=> CE_Overflow_Check_Failed
));
8218 end Expand_Pred_Succ_Attribute
;
8220 ---------------------------
8221 -- Expand_Size_Attribute --
8222 ---------------------------
8224 procedure Expand_Size_Attribute
(N
: Node_Id
) is
8225 Loc
: constant Source_Ptr
:= Sloc
(N
);
8226 Typ
: constant Entity_Id
:= Etype
(N
);
8227 Pref
: constant Node_Id
:= Prefix
(N
);
8228 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
8229 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
8233 -- Case of known RM_Size of a type
8235 if Id
in Attribute_Size | Attribute_Value_Size
8236 and then Is_Entity_Name
(Pref
)
8237 and then Is_Type
(Entity
(Pref
))
8238 and then Known_Static_RM_Size
(Entity
(Pref
))
8240 Siz
:= RM_Size
(Entity
(Pref
));
8242 -- Case of known Esize of a type
8244 elsif Id
= Attribute_Object_Size
8245 and then Is_Entity_Name
(Pref
)
8246 and then Is_Type
(Entity
(Pref
))
8247 and then Known_Static_Esize
(Entity
(Pref
))
8249 Siz
:= Esize
(Entity
(Pref
));
8251 -- Case of known size of object
8253 elsif Id
= Attribute_Size
8254 and then Is_Entity_Name
(Pref
)
8255 and then Is_Object
(Entity
(Pref
))
8256 and then Known_Static_Esize
(Entity
(Pref
))
8258 Siz
:= Esize
(Entity
(Pref
));
8260 -- For an array component, we can do Size in the front end if the
8261 -- component_size of the array is set.
8263 elsif Nkind
(Pref
) = N_Indexed_Component
then
8264 Siz
:= Component_Size
(Etype
(Prefix
(Pref
)));
8266 -- For a record component, we can do Size in the front end if there is a
8267 -- component clause, or if the record is packed and the component's size
8268 -- is known at compile time.
8270 elsif Nkind
(Pref
) = N_Selected_Component
then
8272 Rec
: constant Entity_Id
:= Etype
(Prefix
(Pref
));
8273 Comp
: constant Entity_Id
:= Entity
(Selector_Name
(Pref
));
8276 if Present
(Component_Clause
(Comp
)) then
8277 Siz
:= Esize
(Comp
);
8279 elsif Is_Packed
(Rec
) then
8280 Siz
:= RM_Size
(Ptyp
);
8283 Apply_Universal_Integer_Attribute_Checks
(N
);
8288 -- All other cases are handled by the back end
8291 -- If Size is applied to a formal parameter that is of a packed
8292 -- array subtype, then apply Size to the actual subtype.
8294 if Is_Entity_Name
(Pref
)
8295 and then Is_Formal
(Entity
(Pref
))
8296 and then Is_Packed_Array
(Ptyp
)
8299 Make_Attribute_Reference
(Loc
,
8301 New_Occurrence_Of
(Get_Actual_Subtype
(Pref
), Loc
),
8302 Attribute_Name
=> Name_Size
));
8303 Analyze_And_Resolve
(N
, Typ
);
8305 -- If Size is applied to a dereference of an access to unconstrained
8306 -- packed array, the back end needs to see its unconstrained nominal
8307 -- type, but also a hint to the actual constrained type.
8309 elsif Nkind
(Pref
) = N_Explicit_Dereference
8310 and then Is_Packed_Array
(Ptyp
)
8311 and then not Is_Constrained
(Ptyp
)
8313 Set_Actual_Designated_Subtype
(Pref
, Get_Actual_Subtype
(Pref
));
8315 -- If Size was applied to a slice of a bit-packed array, we rewrite
8316 -- it into the product of Length and Component_Size. We need to do so
8317 -- because bit-packed arrays are represented internally as arrays of
8318 -- System.Unsigned_Types.Packed_Byte for code generation purposes so
8319 -- the size is always rounded up in the back end.
8321 elsif Nkind
(Pref
) = N_Slice
and then Is_Bit_Packed_Array
(Ptyp
) then
8323 Make_Op_Multiply
(Loc
,
8324 Make_Attribute_Reference
(Loc
,
8325 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8326 Attribute_Name
=> Name_Length
),
8327 Make_Attribute_Reference
(Loc
,
8328 Prefix
=> Duplicate_Subexpr
(Pref
, True),
8329 Attribute_Name
=> Name_Component_Size
)));
8330 Analyze_And_Resolve
(N
, Typ
);
8333 -- Apply the required checks last, after rewriting has taken place
8335 Apply_Universal_Integer_Attribute_Checks
(N
);
8339 -- Common processing for record and array component case
8341 if Present
(Siz
) and then Siz
/= 0 then
8343 CS
: constant Boolean := Comes_From_Source
(N
);
8346 Rewrite
(N
, Make_Integer_Literal
(Loc
, Siz
));
8348 -- This integer literal is not a static expression. We do not
8349 -- call Analyze_And_Resolve here, because this would activate
8350 -- the circuit for deciding that a static value was out of range,
8351 -- and we don't want that.
8353 -- So just manually set the type, mark the expression as
8354 -- nonstatic, and then ensure that the result is checked
8355 -- properly if the attribute comes from source (if it was
8356 -- internally generated, we never need a constraint check).
8359 Set_Is_Static_Expression
(N
, False);
8362 Apply_Constraint_Check
(N
, Typ
);
8366 end Expand_Size_Attribute
;
8368 -----------------------------
8369 -- Expand_Update_Attribute --
8370 -----------------------------
8372 procedure Expand_Update_Attribute
(N
: Node_Id
) is
8373 procedure Process_Component_Or_Element_Update
8378 -- Generate the statements necessary to update a single component or an
8379 -- element of the prefix. The code is inserted before the attribute N.
8380 -- Temp denotes the entity of the anonymous object created to reflect
8381 -- the changes in values. Comp is the component/index expression to be
8382 -- updated. Expr is an expression yielding the new value of Comp. Typ
8383 -- is the type of the prefix of attribute Update.
8385 procedure Process_Range_Update
8390 -- Generate the statements necessary to update a slice of the prefix.
8391 -- The code is inserted before the attribute N. Temp denotes the entity
8392 -- of the anonymous object created to reflect the changes in values.
8393 -- Comp is range of the slice to be updated. Expr is an expression
8394 -- yielding the new value of Comp. Typ is the type of the prefix of
8395 -- attribute Update.
8397 -----------------------------------------
8398 -- Process_Component_Or_Element_Update --
8399 -----------------------------------------
8401 procedure Process_Component_Or_Element_Update
8407 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8412 -- An array element may be modified by the following relations
8413 -- depending on the number of dimensions:
8415 -- 1 => Expr -- one dimensional update
8416 -- (1, ..., N) => Expr -- multi dimensional update
8418 -- The above forms are converted in assignment statements where the
8419 -- left hand side is an indexed component:
8421 -- Temp (1) := Expr; -- one dimensional update
8422 -- Temp (1, ..., N) := Expr; -- multi dimensional update
8424 if Is_Array_Type
(Typ
) then
8426 -- The index expressions of a multi dimensional array update
8427 -- appear as an aggregate.
8429 if Nkind
(Comp
) = N_Aggregate
then
8430 Exprs
:= New_Copy_List_Tree
(Expressions
(Comp
));
8432 Exprs
:= New_List
(Relocate_Node
(Comp
));
8436 Make_Indexed_Component
(Loc
,
8437 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8438 Expressions
=> Exprs
);
8440 -- A record component update appears in the following form:
8444 -- The above relation is transformed into an assignment statement
8445 -- where the left hand side is a selected component:
8447 -- Temp.Comp := Expr;
8449 else pragma Assert
(Is_Record_Type
(Typ
));
8451 Make_Selected_Component
(Loc
,
8452 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8453 Selector_Name
=> Relocate_Node
(Comp
));
8457 Make_Assignment_Statement
(Loc
,
8459 Expression
=> Relocate_Node
(Expr
)));
8460 end Process_Component_Or_Element_Update
;
8462 --------------------------
8463 -- Process_Range_Update --
8464 --------------------------
8466 procedure Process_Range_Update
8472 Index_Typ
: constant Entity_Id
:= Etype
(First_Index
(Typ
));
8473 Loc
: constant Source_Ptr
:= Sloc
(Comp
);
8477 -- A range update appears as
8479 -- (Low .. High => Expr)
8481 -- The above construct is transformed into a loop that iterates over
8482 -- the given range and modifies the corresponding array values to the
8485 -- for Index in Low .. High loop
8486 -- Temp (<Index_Typ> (Index)) := Expr;
8489 Index
:= Make_Temporary
(Loc
, 'I');
8492 Make_Loop_Statement
(Loc
,
8494 Make_Iteration_Scheme
(Loc
,
8495 Loop_Parameter_Specification
=>
8496 Make_Loop_Parameter_Specification
(Loc
,
8497 Defining_Identifier
=> Index
,
8498 Discrete_Subtype_Definition
=> Relocate_Node
(Comp
))),
8500 Statements
=> New_List
(
8501 Make_Assignment_Statement
(Loc
,
8503 Make_Indexed_Component
(Loc
,
8504 Prefix
=> New_Occurrence_Of
(Temp
, Loc
),
8505 Expressions
=> New_List
(
8506 Convert_To
(Index_Typ
,
8507 New_Occurrence_Of
(Index
, Loc
)))),
8508 Expression
=> Relocate_Node
(Expr
))),
8510 End_Label
=> Empty
));
8511 end Process_Range_Update
;
8515 Aggr
: constant Node_Id
:= First
(Expressions
(N
));
8516 Loc
: constant Source_Ptr
:= Sloc
(N
);
8517 Pref
: constant Node_Id
:= Prefix
(N
);
8518 Typ
: constant Entity_Id
:= Etype
(Pref
);
8521 CW_Temp
: Entity_Id
;
8526 -- Start of processing for Expand_Update_Attribute
8529 -- Create the anonymous object to store the value of the prefix and
8530 -- capture subsequent changes in value.
8532 Temp
:= Make_Temporary
(Loc
, 'T', Pref
);
8534 -- Preserve the tag of the prefix by offering a specific view of the
8535 -- class-wide version of the prefix.
8537 if Is_Tagged_Type
(Typ
) then
8540 -- CW_Temp : Typ'Class := Typ'Class (Pref);
8542 CW_Temp
:= Make_Temporary
(Loc
, 'T');
8543 CW_Typ
:= Class_Wide_Type
(Typ
);
8546 Make_Object_Declaration
(Loc
,
8547 Defining_Identifier
=> CW_Temp
,
8548 Object_Definition
=> New_Occurrence_Of
(CW_Typ
, Loc
),
8550 Convert_To
(CW_Typ
, Relocate_Node
(Pref
))));
8553 -- Temp : Typ renames Typ (CW_Temp);
8556 Make_Object_Renaming_Declaration
(Loc
,
8557 Defining_Identifier
=> Temp
,
8558 Subtype_Mark
=> New_Occurrence_Of
(Typ
, Loc
),
8560 Convert_To
(Typ
, New_Occurrence_Of
(CW_Temp
, Loc
))));
8566 -- Temp : Typ := Pref;
8569 Make_Object_Declaration
(Loc
,
8570 Defining_Identifier
=> Temp
,
8571 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
),
8572 Expression
=> Relocate_Node
(Pref
)));
8575 -- Process the update aggregate
8577 Assoc
:= First
(Component_Associations
(Aggr
));
8578 while Present
(Assoc
) loop
8579 Comp
:= First
(Choices
(Assoc
));
8580 Expr
:= Expression
(Assoc
);
8581 while Present
(Comp
) loop
8582 if Nkind
(Comp
) = N_Range
then
8583 Process_Range_Update
(Temp
, Comp
, Expr
, Typ
);
8584 elsif Nkind
(Comp
) = N_Subtype_Indication
then
8585 Process_Range_Update
8586 (Temp
, Range_Expression
(Constraint
(Comp
)), Expr
, Typ
);
8588 Process_Component_Or_Element_Update
(Temp
, Comp
, Expr
, Typ
);
8597 -- The attribute is replaced by a reference to the anonymous object
8599 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
8601 end Expand_Update_Attribute
;
8607 procedure Find_Fat_Info
8609 Fat_Type
: out Entity_Id
;
8610 Fat_Pkg
: out RE_Id
)
8612 Rtyp
: constant Entity_Id
:= Root_Type
(T
);
8615 -- All we do is use the root type (historically this dealt with
8616 -- VAX-float .. to be cleaned up further later ???)
8618 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
8619 Fat_Type
:= Standard_Float
;
8620 Fat_Pkg
:= RE_Attr_Float
;
8622 elsif Rtyp
= Standard_Long_Float
then
8623 Fat_Type
:= Standard_Long_Float
;
8624 Fat_Pkg
:= RE_Attr_Long_Float
;
8626 elsif Rtyp
= Standard_Long_Long_Float
then
8627 Fat_Type
:= Standard_Long_Long_Float
;
8628 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8630 -- Universal real (which is its own root type) is treated as being
8631 -- equivalent to Standard.Long_Long_Float, since it is defined to
8632 -- have the same precision as the longest Float type.
8634 elsif Rtyp
= Universal_Real
then
8635 Fat_Type
:= Standard_Long_Long_Float
;
8636 Fat_Pkg
:= RE_Attr_Long_Long_Float
;
8639 raise Program_Error
;
8643 ----------------------------
8644 -- Find_Stream_Subprogram --
8645 ----------------------------
8647 function Find_Stream_Subprogram
8649 Nam
: TSS_Name_Type
;
8650 Attr_Ref
: Node_Id
) return Entity_Id
8653 function In_Available_Context
(Ent
: Entity_Id
) return Boolean;
8654 -- Ent is a candidate result for Find_Stream_Subprogram.
8655 -- If, for example, a subprogram is declared within a case
8656 -- alternative then Gigi does not want to see a call to it from
8657 -- outside of the case alternative. Compare placement of Ent and
8658 -- Attr_Ref to prevent this situation (by returning False).
8660 --------------------------
8661 -- In_Available_Context --
8662 --------------------------
8664 function In_Available_Context
(Ent
: Entity_Id
) return Boolean is
8665 Decl
: Node_Id
:= Enclosing_Declaration
(Ent
);
8667 -- Enclosing_Declaration does not always return a declaration;
8668 -- cope with this irregularity.
8669 if Decl
in N_Subprogram_Specification_Id
8670 and then Nkind
(Parent
(Decl
)) in
8671 N_Subprogram_Body | N_Subprogram_Declaration
8673 Decl
:= Parent
(Decl
);
8676 if Has_Declarations
(Parent
(Decl
)) then
8677 return In_Subtree
(Attr_Ref
, Root
=> Parent
(Decl
));
8678 elsif Is_List_Member
(Decl
) then
8680 List_Elem
: Node_Id
:= Next
(Decl
);
8682 while Present
(List_Elem
) loop
8683 if In_Subtree
(Attr_Ref
, Root
=> List_Elem
) then
8691 return False; -- Can this occur ???
8693 end In_Available_Context
;
8695 -- Local declarations
8697 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8698 Ent
: Entity_Id
:= TSS
(Typ
, Nam
);
8700 -- Start of processing for Find_Stream_Subprogram
8703 if Present
(Ent
) then
8707 -- Everything after this point is an optimization. In other words,
8708 -- there should be no *correctness* problems if we were to
8709 -- unconditionally return Empty here.
8711 if Is_Unchecked_Union
(Base_Typ
) then
8712 -- Conservatively avoid possible problems (e.g., Write behaves
8713 -- differently for a U_U type when called by Output vs. when
8714 -- called from elsewhere).
8719 if Nam
= TSS_Stream_Read
then
8720 Ent
:= Cached_Streaming_Ops
.Read_Map
.Get
(Typ
);
8721 elsif Nam
= TSS_Stream_Write
then
8722 Ent
:= Cached_Streaming_Ops
.Write_Map
.Get
(Typ
);
8723 elsif Nam
= TSS_Stream_Input
then
8724 Ent
:= Cached_Streaming_Ops
.Input_Map
.Get
(Typ
);
8725 elsif Nam
= TSS_Stream_Output
then
8726 Ent
:= Cached_Streaming_Ops
.Output_Map
.Get
(Typ
);
8729 if Present
(Ent
) then
8730 -- Can't reuse Ent if it is no longer in scope
8732 if In_Open_Scopes
(Scope
(Ent
))
8734 -- The preceding In_Open_Scopes test may not suffice if
8735 -- case alternatives are involved.
8736 and then In_Available_Context
(Ent
)
8744 -- Stream attributes for strings are expanded into library calls. The
8745 -- following checks are disabled when the run-time is not available or
8746 -- when compiling predefined types due to bootstrap issues. As a result,
8747 -- the compiler will generate in-place stream routines for string types
8748 -- that appear in GNAT's library, but will generate calls via rtsfind
8749 -- to library routines for user code.
8751 -- Note: In the case of using a configurable run time, it is very likely
8752 -- that stream routines for string types are not present (they require
8753 -- file system support). In this case, the specific stream routines for
8754 -- strings are not used, relying on the regular stream mechanism
8755 -- instead. That is why we include the test RTE_Available when dealing
8756 -- with these cases.
8758 if not Is_Predefined_Unit
(Current_Sem_Unit
) then
8759 -- Storage_Array as defined in package System.Storage_Elements
8761 if Is_RTE
(Base_Typ
, RE_Storage_Array
) then
8763 -- Case of No_Stream_Optimizations restriction active
8765 if Restriction_Active
(No_Stream_Optimizations
) then
8766 if Nam
= TSS_Stream_Input
8767 and then RTE_Available
(RE_Storage_Array_Input
)
8769 return RTE
(RE_Storage_Array_Input
);
8771 elsif Nam
= TSS_Stream_Output
8772 and then RTE_Available
(RE_Storage_Array_Output
)
8774 return RTE
(RE_Storage_Array_Output
);
8776 elsif Nam
= TSS_Stream_Read
8777 and then RTE_Available
(RE_Storage_Array_Read
)
8779 return RTE
(RE_Storage_Array_Read
);
8781 elsif Nam
= TSS_Stream_Write
8782 and then RTE_Available
(RE_Storage_Array_Write
)
8784 return RTE
(RE_Storage_Array_Write
);
8786 elsif Nam
/= TSS_Stream_Input
and then
8787 Nam
/= TSS_Stream_Output
and then
8788 Nam
/= TSS_Stream_Read
and then
8789 Nam
/= TSS_Stream_Write
8791 raise Program_Error
;
8794 -- Restriction No_Stream_Optimizations is not set, so we can go
8795 -- ahead and optimize using the block IO forms of the routines.
8798 if Nam
= TSS_Stream_Input
8799 and then RTE_Available
(RE_Storage_Array_Input_Blk_IO
)
8801 return RTE
(RE_Storage_Array_Input_Blk_IO
);
8803 elsif Nam
= TSS_Stream_Output
8804 and then RTE_Available
(RE_Storage_Array_Output_Blk_IO
)
8806 return RTE
(RE_Storage_Array_Output_Blk_IO
);
8808 elsif Nam
= TSS_Stream_Read
8809 and then RTE_Available
(RE_Storage_Array_Read_Blk_IO
)
8811 return RTE
(RE_Storage_Array_Read_Blk_IO
);
8813 elsif Nam
= TSS_Stream_Write
8814 and then RTE_Available
(RE_Storage_Array_Write_Blk_IO
)
8816 return RTE
(RE_Storage_Array_Write_Blk_IO
);
8818 elsif Nam
/= TSS_Stream_Input
and then
8819 Nam
/= TSS_Stream_Output
and then
8820 Nam
/= TSS_Stream_Read
and then
8821 Nam
/= TSS_Stream_Write
8823 raise Program_Error
;
8827 -- Stream_Element_Array as defined in package Ada.Streams
8829 elsif Is_RTE
(Base_Typ
, RE_Stream_Element_Array
) then
8831 -- Case of No_Stream_Optimizations restriction active
8833 if Restriction_Active
(No_Stream_Optimizations
) then
8834 if Nam
= TSS_Stream_Input
8835 and then RTE_Available
(RE_Stream_Element_Array_Input
)
8837 return RTE
(RE_Stream_Element_Array_Input
);
8839 elsif Nam
= TSS_Stream_Output
8840 and then RTE_Available
(RE_Stream_Element_Array_Output
)
8842 return RTE
(RE_Stream_Element_Array_Output
);
8844 elsif Nam
= TSS_Stream_Read
8845 and then RTE_Available
(RE_Stream_Element_Array_Read
)
8847 return RTE
(RE_Stream_Element_Array_Read
);
8849 elsif Nam
= TSS_Stream_Write
8850 and then RTE_Available
(RE_Stream_Element_Array_Write
)
8852 return RTE
(RE_Stream_Element_Array_Write
);
8854 elsif Nam
/= TSS_Stream_Input
and then
8855 Nam
/= TSS_Stream_Output
and then
8856 Nam
/= TSS_Stream_Read
and then
8857 Nam
/= TSS_Stream_Write
8859 raise Program_Error
;
8862 -- Restriction No_Stream_Optimizations is not set, so we can go
8863 -- ahead and optimize using the block IO forms of the routines.
8866 if Nam
= TSS_Stream_Input
8867 and then RTE_Available
(RE_Stream_Element_Array_Input_Blk_IO
)
8869 return RTE
(RE_Stream_Element_Array_Input_Blk_IO
);
8871 elsif Nam
= TSS_Stream_Output
8872 and then RTE_Available
(RE_Stream_Element_Array_Output_Blk_IO
)
8874 return RTE
(RE_Stream_Element_Array_Output_Blk_IO
);
8876 elsif Nam
= TSS_Stream_Read
8877 and then RTE_Available
(RE_Stream_Element_Array_Read_Blk_IO
)
8879 return RTE
(RE_Stream_Element_Array_Read_Blk_IO
);
8881 elsif Nam
= TSS_Stream_Write
8882 and then RTE_Available
(RE_Stream_Element_Array_Write_Blk_IO
)
8884 return RTE
(RE_Stream_Element_Array_Write_Blk_IO
);
8886 elsif Nam
/= TSS_Stream_Input
and then
8887 Nam
/= TSS_Stream_Output
and then
8888 Nam
/= TSS_Stream_Read
and then
8889 Nam
/= TSS_Stream_Write
8891 raise Program_Error
;
8895 -- String as defined in package Ada
8897 elsif Base_Typ
= Standard_String
then
8899 -- Case of No_Stream_Optimizations restriction active
8901 if Restriction_Active
(No_Stream_Optimizations
) then
8902 if Nam
= TSS_Stream_Input
8903 and then RTE_Available
(RE_String_Input
)
8905 return RTE
(RE_String_Input
);
8907 elsif Nam
= TSS_Stream_Output
8908 and then RTE_Available
(RE_String_Output
)
8910 return RTE
(RE_String_Output
);
8912 elsif Nam
= TSS_Stream_Read
8913 and then RTE_Available
(RE_String_Read
)
8915 return RTE
(RE_String_Read
);
8917 elsif Nam
= TSS_Stream_Write
8918 and then RTE_Available
(RE_String_Write
)
8920 return RTE
(RE_String_Write
);
8922 elsif Nam
/= TSS_Stream_Input
and then
8923 Nam
/= TSS_Stream_Output
and then
8924 Nam
/= TSS_Stream_Read
and then
8925 Nam
/= TSS_Stream_Write
8927 raise Program_Error
;
8930 -- Restriction No_Stream_Optimizations is not set, so we can go
8931 -- ahead and optimize using the block IO forms of the routines.
8934 if Nam
= TSS_Stream_Input
8935 and then RTE_Available
(RE_String_Input_Blk_IO
)
8937 return RTE
(RE_String_Input_Blk_IO
);
8939 elsif Nam
= TSS_Stream_Output
8940 and then RTE_Available
(RE_String_Output_Blk_IO
)
8942 return RTE
(RE_String_Output_Blk_IO
);
8944 elsif Nam
= TSS_Stream_Read
8945 and then RTE_Available
(RE_String_Read_Blk_IO
)
8947 return RTE
(RE_String_Read_Blk_IO
);
8949 elsif Nam
= TSS_Stream_Write
8950 and then RTE_Available
(RE_String_Write_Blk_IO
)
8952 return RTE
(RE_String_Write_Blk_IO
);
8954 elsif Nam
/= TSS_Stream_Input
and then
8955 Nam
/= TSS_Stream_Output
and then
8956 Nam
/= TSS_Stream_Read
and then
8957 Nam
/= TSS_Stream_Write
8959 raise Program_Error
;
8963 -- Wide_String as defined in package Ada
8965 elsif Base_Typ
= Standard_Wide_String
then
8967 -- Case of No_Stream_Optimizations restriction active
8969 if Restriction_Active
(No_Stream_Optimizations
) then
8970 if Nam
= TSS_Stream_Input
8971 and then RTE_Available
(RE_Wide_String_Input
)
8973 return RTE
(RE_Wide_String_Input
);
8975 elsif Nam
= TSS_Stream_Output
8976 and then RTE_Available
(RE_Wide_String_Output
)
8978 return RTE
(RE_Wide_String_Output
);
8980 elsif Nam
= TSS_Stream_Read
8981 and then RTE_Available
(RE_Wide_String_Read
)
8983 return RTE
(RE_Wide_String_Read
);
8985 elsif Nam
= TSS_Stream_Write
8986 and then RTE_Available
(RE_Wide_String_Write
)
8988 return RTE
(RE_Wide_String_Write
);
8990 elsif Nam
/= TSS_Stream_Input
and then
8991 Nam
/= TSS_Stream_Output
and then
8992 Nam
/= TSS_Stream_Read
and then
8993 Nam
/= TSS_Stream_Write
8995 raise Program_Error
;
8998 -- Restriction No_Stream_Optimizations is not set, so we can go
8999 -- ahead and optimize using the block IO forms of the routines.
9002 if Nam
= TSS_Stream_Input
9003 and then RTE_Available
(RE_Wide_String_Input_Blk_IO
)
9005 return RTE
(RE_Wide_String_Input_Blk_IO
);
9007 elsif Nam
= TSS_Stream_Output
9008 and then RTE_Available
(RE_Wide_String_Output_Blk_IO
)
9010 return RTE
(RE_Wide_String_Output_Blk_IO
);
9012 elsif Nam
= TSS_Stream_Read
9013 and then RTE_Available
(RE_Wide_String_Read_Blk_IO
)
9015 return RTE
(RE_Wide_String_Read_Blk_IO
);
9017 elsif Nam
= TSS_Stream_Write
9018 and then RTE_Available
(RE_Wide_String_Write_Blk_IO
)
9020 return RTE
(RE_Wide_String_Write_Blk_IO
);
9022 elsif Nam
/= TSS_Stream_Input
and then
9023 Nam
/= TSS_Stream_Output
and then
9024 Nam
/= TSS_Stream_Read
and then
9025 Nam
/= TSS_Stream_Write
9027 raise Program_Error
;
9031 -- Wide_Wide_String as defined in package Ada
9033 elsif Base_Typ
= Standard_Wide_Wide_String
then
9035 -- Case of No_Stream_Optimizations restriction active
9037 if Restriction_Active
(No_Stream_Optimizations
) then
9038 if Nam
= TSS_Stream_Input
9039 and then RTE_Available
(RE_Wide_Wide_String_Input
)
9041 return RTE
(RE_Wide_Wide_String_Input
);
9043 elsif Nam
= TSS_Stream_Output
9044 and then RTE_Available
(RE_Wide_Wide_String_Output
)
9046 return RTE
(RE_Wide_Wide_String_Output
);
9048 elsif Nam
= TSS_Stream_Read
9049 and then RTE_Available
(RE_Wide_Wide_String_Read
)
9051 return RTE
(RE_Wide_Wide_String_Read
);
9053 elsif Nam
= TSS_Stream_Write
9054 and then RTE_Available
(RE_Wide_Wide_String_Write
)
9056 return RTE
(RE_Wide_Wide_String_Write
);
9058 elsif Nam
/= TSS_Stream_Input
and then
9059 Nam
/= TSS_Stream_Output
and then
9060 Nam
/= TSS_Stream_Read
and then
9061 Nam
/= TSS_Stream_Write
9063 raise Program_Error
;
9066 -- Restriction No_Stream_Optimizations is not set, so we can go
9067 -- ahead and optimize using the block IO forms of the routines.
9070 if Nam
= TSS_Stream_Input
9071 and then RTE_Available
(RE_Wide_Wide_String_Input_Blk_IO
)
9073 return RTE
(RE_Wide_Wide_String_Input_Blk_IO
);
9075 elsif Nam
= TSS_Stream_Output
9076 and then RTE_Available
(RE_Wide_Wide_String_Output_Blk_IO
)
9078 return RTE
(RE_Wide_Wide_String_Output_Blk_IO
);
9080 elsif Nam
= TSS_Stream_Read
9081 and then RTE_Available
(RE_Wide_Wide_String_Read_Blk_IO
)
9083 return RTE
(RE_Wide_Wide_String_Read_Blk_IO
);
9085 elsif Nam
= TSS_Stream_Write
9086 and then RTE_Available
(RE_Wide_Wide_String_Write_Blk_IO
)
9088 return RTE
(RE_Wide_Wide_String_Write_Blk_IO
);
9090 elsif Nam
/= TSS_Stream_Input
and then
9091 Nam
/= TSS_Stream_Output
and then
9092 Nam
/= TSS_Stream_Read
and then
9093 Nam
/= TSS_Stream_Write
9095 raise Program_Error
;
9101 if Is_Tagged_Type
(Typ
) and then Is_Derived_Type
(Typ
) then
9102 return Find_Prim_Op
(Typ
, Nam
);
9104 return Find_Inherited_TSS
(Typ
, Nam
);
9106 end Find_Stream_Subprogram
;
9112 function Full_Base
(T
: Entity_Id
) return Entity_Id
is
9116 BT
:= Base_Type
(T
);
9118 if Is_Private_Type
(BT
)
9119 and then Present
(Full_View
(BT
))
9121 BT
:= Full_View
(BT
);
9127 -------------------------------
9128 -- Get_Stream_Convert_Pragma --
9129 -------------------------------
9131 function Get_Stream_Convert_Pragma
(T
: Entity_Id
) return Node_Id
is
9136 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
9137 -- that a stream convert pragma for a tagged type is not inherited from
9138 -- its parent. Probably what is wrong here is that it is basically
9139 -- incorrect to consider a stream convert pragma to be a representation
9140 -- pragma at all ???
9142 N
:= First_Rep_Item
(Implementation_Base_Type
(T
));
9143 while Present
(N
) loop
9144 if Nkind
(N
) = N_Pragma
9145 and then Pragma_Name
(N
) = Name_Stream_Convert
9147 -- For tagged types this pragma is not inherited, so we
9148 -- must verify that it is defined for the given type and
9152 Entity
(Expression
(First
(Pragma_Argument_Associations
(N
))));
9154 if not Is_Tagged_Type
(T
)
9156 or else (Is_Private_Type
(Typ
) and then T
= Full_View
(Typ
))
9166 end Get_Stream_Convert_Pragma
;
9168 ---------------------------------
9169 -- Is_Constrained_Packed_Array --
9170 ---------------------------------
9172 function Is_Constrained_Packed_Array
(Typ
: Entity_Id
) return Boolean is
9173 Arr
: Entity_Id
:= Typ
;
9176 if Is_Access_Type
(Arr
) then
9177 Arr
:= Designated_Type
(Arr
);
9180 return Is_Array_Type
(Arr
)
9181 and then Is_Constrained
(Arr
)
9182 and then Present
(Packed_Array_Impl_Type
(Arr
));
9183 end Is_Constrained_Packed_Array
;
9185 ----------------------------------------
9186 -- Is_Inline_Floating_Point_Attribute --
9187 ----------------------------------------
9189 function Is_Inline_Floating_Point_Attribute
(N
: Node_Id
) return Boolean is
9190 Id
: constant Attribute_Id
:= Get_Attribute_Id
(Attribute_Name
(N
));
9192 function Is_GCC_Target
return Boolean;
9193 -- Return True if we are using a GCC target/back-end
9194 -- ??? Note: the implementation is kludgy/fragile
9200 function Is_GCC_Target
return Boolean is
9202 return not CodePeer_Mode
9203 and then not Modify_Tree_For_C
;
9206 -- Start of processing for Is_Inline_Floating_Point_Attribute
9209 -- Machine and Model can be expanded by the GCC back end only
9211 if Id
= Attribute_Machine
or else Id
= Attribute_Model
then
9212 return Is_GCC_Target
;
9214 -- Remaining cases handled by all back ends are Rounding and Truncation
9215 -- when appearing as the operand of a conversion to some integer type.
9217 elsif Nkind
(Parent
(N
)) /= N_Type_Conversion
9218 or else not Is_Integer_Type
(Etype
(Parent
(N
)))
9223 -- Here we are in the integer conversion context. We reuse Rounding for
9224 -- Machine_Rounding as System.Fat_Gen, which is a permissible behavior.
9227 Id
= Attribute_Rounding
9228 or else Id
= Attribute_Machine_Rounding
9229 or else Id
= Attribute_Truncation
;
9230 end Is_Inline_Floating_Point_Attribute
;