1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Exp_Atag; use Exp_Atag;
32 with Exp_Ch2; use Exp_Ch2;
33 with Exp_Ch3; use Exp_Ch3;
34 with Exp_Ch6; use Exp_Ch6;
35 with Exp_Ch9; use Exp_Ch9;
36 with Exp_Dist; use Exp_Dist;
37 with Exp_Imgv; use Exp_Imgv;
38 with Exp_Pakd; use Exp_Pakd;
39 with Exp_Strm; use Exp_Strm;
40 with Exp_Tss; use Exp_Tss;
41 with Exp_Util; use Exp_Util;
42 with Freeze; use Freeze;
43 with Gnatvsn; use Gnatvsn;
44 with Itypes; use Itypes;
46 with Namet; use Namet;
47 with Nmake; use Nmake;
48 with Nlists; use Nlists;
50 with Restrict; use Restrict;
51 with Rident; use Rident;
52 with Rtsfind; use Rtsfind;
54 with Sem_Aux; use Sem_Aux;
55 with Sem_Ch6; use Sem_Ch6;
56 with Sem_Ch7; use Sem_Ch7;
57 with Sem_Ch8; use Sem_Ch8;
58 with Sem_Eval; use Sem_Eval;
59 with Sem_Res; use Sem_Res;
60 with Sem_Util; use Sem_Util;
61 with Sinfo; use Sinfo;
62 with Snames; use Snames;
63 with Stand; use Stand;
64 with Stringt; use Stringt;
65 with Tbuild; use Tbuild;
66 with Ttypes; use Ttypes;
67 with Uintp; use Uintp;
68 with Uname; use Uname;
69 with Validsw; use Validsw;
71 package body Exp_Attr is
73 -----------------------
74 -- Local Subprograms --
75 -----------------------
77 function Build_Array_VS_Func
79 Formal_Typ : Entity_Id;
80 Array_Typ : Entity_Id;
81 Comp_Typ : Entity_Id) return Entity_Id;
82 -- Validate the components of an array type by means of a function. Return
83 -- the entity of the validation function. The parameters are as follows:
85 -- * Attr - the 'Valid_Scalars attribute for which the function is
88 -- * Formal_Typ - the type of the generated function's only formal
91 -- * Array_Typ - the array type whose components are to be validated
93 -- * Comp_Typ - the component type of the array
95 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
96 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
98 function Build_Record_VS_Func
100 Formal_Typ : Entity_Id;
101 Rec_Typ : Entity_Id) return Entity_Id;
102 -- Validate the components, discriminants, and variants of a record type by
103 -- means of a function. Return the entity of the validation function. The
104 -- parameters are as follows:
106 -- * Attr - the 'Valid_Scalars attribute for which the function is
109 -- * Formal_Typ - the type of the generated function's only formal
112 -- * Rec_Typ - the record type whose internals are to be validated
114 procedure Compile_Stream_Body_In_Scope
119 -- The body for a stream subprogram may be generated outside of the scope
120 -- of the type. If the type is fully private, it may depend on the full
121 -- view of other types (e.g. indexes) that are currently private as well.
122 -- We install the declarations of the package in which the type is declared
123 -- before compiling the body in what is its proper environment. The Check
124 -- parameter indicates if checks are to be suppressed for the stream body.
125 -- We suppress checks for array/record reads, since the rule is that these
126 -- are like assignments, out of range values due to uninitialized storage,
127 -- or other invalid values do NOT cause a Constraint_Error to be raised.
128 -- If we are within an instance body all visibility has been established
129 -- already and there is no need to install the package.
131 -- This mechanism is now extended to the component types of the array type,
132 -- when the component type is not in scope and is private, to handle
133 -- properly the case when the full view has defaulted discriminants.
135 -- This special processing is ultimately caused by the fact that the
136 -- compiler lacks a well-defined phase when full views are visible
137 -- everywhere. Having such a separate pass would remove much of the
138 -- special-case code that shuffles partial and full views in the middle
139 -- of semantic analysis and expansion.
141 procedure Expand_Access_To_Protected_Op
145 -- An attribute reference to a protected subprogram is transformed into
146 -- a pair of pointers: one to the object, and one to the operations.
147 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
149 procedure Expand_Fpt_Attribute
154 -- This procedure expands a call to a floating-point attribute function.
155 -- N is the attribute reference node, and Args is a list of arguments to
156 -- be passed to the function call. Pkg identifies the package containing
157 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
158 -- have already been converted to the floating-point type for which Pkg was
159 -- instantiated. The Nam argument is the relevant attribute processing
160 -- routine to be called. This is the same as the attribute name, except in
161 -- the Unaligned_Valid case.
163 procedure Expand_Fpt_Attribute_R (N : Node_Id);
164 -- This procedure expands a call to a floating-point attribute function
165 -- that takes a single floating-point argument. The function to be called
166 -- is always the same as the attribute name.
168 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
169 -- This procedure expands a call to a floating-point attribute function
170 -- that takes one floating-point argument and one integer argument. The
171 -- function to be called is always the same as the attribute name.
173 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
174 -- This procedure expands a call to a floating-point attribute function
175 -- that takes two floating-point arguments. The function to be called
176 -- is always the same as the attribute name.
178 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
179 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
180 -- loop may be converted into a conditional block. See body for details.
182 procedure Expand_Min_Max_Attribute (N : Node_Id);
183 -- Handle the expansion of attributes 'Max and 'Min, including expanding
184 -- then out if we are in Modify_Tree_For_C mode.
186 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
187 -- Handles expansion of Pred or Succ attributes for case of non-real
188 -- operand with overflow checking required.
190 procedure Expand_Update_Attribute (N : Node_Id);
191 -- Handle the expansion of attribute Update
193 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
194 -- Used for Last, Last, and Length, when the prefix is an array type.
195 -- Obtains the corresponding index subtype.
197 procedure Find_Fat_Info
199 Fat_Type : out Entity_Id;
200 Fat_Pkg : out RE_Id);
201 -- Given a floating-point type T, identifies the package containing the
202 -- attributes for this type (returned in Fat_Pkg), and the corresponding
203 -- type for which this package was instantiated from Fat_Gen. Error if T
204 -- is not a floating-point type.
206 function Find_Stream_Subprogram
208 Nam : TSS_Name_Type) return Entity_Id;
209 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
210 -- types, the corresponding primitive operation is looked up, else the
211 -- appropriate TSS from the type itself, or from its closest ancestor
212 -- defining it, is returned. In both cases, inheritance of representation
213 -- aspects is thus taken into account.
215 function Full_Base (T : Entity_Id) return Entity_Id;
216 -- The stream functions need to examine the underlying representation of
217 -- composite types. In some cases T may be non-private but its base type
218 -- is, in which case the function returns the corresponding full view.
220 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
221 -- Given a type, find a corresponding stream convert pragma that applies to
222 -- the implementation base type of this type (Typ). If found, return the
223 -- pragma node, otherwise return Empty if no pragma is found.
225 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
226 -- Utility for array attributes, returns true on packed constrained
227 -- arrays, and on access to same.
229 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
230 -- Returns true iff the given node refers to an attribute call that
231 -- can be expanded directly by the back end and does not need front end
232 -- expansion. Typically used for rounding and truncation attributes that
233 -- appear directly inside a conversion to integer.
235 -------------------------
236 -- Build_Array_VS_Func --
237 -------------------------
239 function Build_Array_VS_Func
241 Formal_Typ : Entity_Id;
242 Array_Typ : Entity_Id;
243 Comp_Typ : Entity_Id) return Entity_Id
245 Loc : constant Source_Ptr := Sloc (Attr);
247 function Validate_Component
249 Indexes : List_Id) return Node_Id;
250 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
251 -- the entity of the validation parameter. Return the check associated
252 -- with the component.
254 function Validate_Dimension
257 Indexes : List_Id) return Node_Id;
258 -- Process dimension Dim of the array type. Obj_Id denotes the entity
259 -- of the validation parameter. Indexes is a list where each dimension
260 -- deposits its loop variable, which will later identify a component.
261 -- Return the loop associated with the current dimension.
263 ------------------------
264 -- Validate_Component --
265 ------------------------
267 function Validate_Component
269 Indexes : List_Id) return Node_Id
274 if Is_Scalar_Type (Comp_Typ) then
275 Attr_Nam := Name_Valid;
277 Attr_Nam := Name_Valid_Scalars;
281 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
286 Make_If_Statement (Loc,
290 Make_Attribute_Reference (Loc,
292 Make_Indexed_Component (Loc,
294 Unchecked_Convert_To (Array_Typ,
295 New_Occurrence_Of (Obj_Id, Loc)),
296 Expressions => Indexes),
297 Attribute_Name => Attr_Nam)),
299 Then_Statements => New_List (
300 Make_Simple_Return_Statement (Loc,
301 Expression => New_Occurrence_Of (Standard_False, Loc))));
302 end Validate_Component;
304 ------------------------
305 -- Validate_Dimension --
306 ------------------------
308 function Validate_Dimension
311 Indexes : List_Id) return Node_Id
316 -- Validate the component once all dimensions have produced their
319 if Dim > Number_Dimensions (Array_Typ) then
320 return Validate_Component (Obj_Id, Indexes);
322 -- Process the current dimension
326 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
328 Append_To (Indexes, New_Occurrence_Of (Index, Loc));
331 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
332 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
333 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
341 Make_Implicit_Loop_Statement (Attr,
344 Make_Iteration_Scheme (Loc,
345 Loop_Parameter_Specification =>
346 Make_Loop_Parameter_Specification (Loc,
347 Defining_Identifier => Index,
348 Discrete_Subtype_Definition =>
349 Make_Attribute_Reference (Loc,
351 Unchecked_Convert_To (Array_Typ,
352 New_Occurrence_Of (Obj_Id, Loc)),
353 Attribute_Name => Name_Range,
354 Expressions => New_List (
355 Make_Integer_Literal (Loc, Dim))))),
356 Statements => New_List (
357 Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
359 end Validate_Dimension;
363 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
364 Indexes : constant List_Id := New_List;
365 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
368 -- Start of processing for Build_Array_VS_Func
371 Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
377 Make_Simple_Return_Statement (Loc,
378 Expression => New_Occurrence_Of (Standard_True, Loc)));
381 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
386 Set_Ekind (Func_Id, E_Function);
387 Set_Is_Internal (Func_Id);
388 Set_Is_Pure (Func_Id);
390 if not Debug_Generated_Code then
391 Set_Debug_Info_Off (Func_Id);
395 Make_Subprogram_Body (Loc,
397 Make_Function_Specification (Loc,
398 Defining_Unit_Name => Func_Id,
399 Parameter_Specifications => New_List (
400 Make_Parameter_Specification (Loc,
401 Defining_Identifier => Obj_Id,
403 Out_Present => False,
404 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
406 New_Occurrence_Of (Standard_Boolean, Loc)),
407 Declarations => New_List,
408 Handled_Statement_Sequence =>
409 Make_Handled_Sequence_Of_Statements (Loc,
410 Statements => Stmts)));
413 end Build_Array_VS_Func;
415 ---------------------------------
416 -- Build_Disp_Get_Task_Id_Call --
417 ---------------------------------
419 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is
420 Loc : constant Source_Ptr := Sloc (Actual);
421 Typ : constant Entity_Id := Etype (Actual);
422 Subp : constant Entity_Id := Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id);
426 -- _Disp_Get_Task_Id (Actual)
429 Make_Function_Call (Loc,
430 Name => New_Occurrence_Of (Subp, Loc),
431 Parameter_Associations => New_List (Actual));
432 end Build_Disp_Get_Task_Id_Call;
434 --------------------------
435 -- Build_Record_VS_Func --
436 --------------------------
438 function Build_Record_VS_Func
440 Formal_Typ : Entity_Id;
441 Rec_Typ : Entity_Id) return Entity_Id
443 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
444 -- It generates code only when there are components, discriminants,
445 -- or variant parts to validate.
447 -- NOTE: The routines within Build_Record_VS_Func are intentionally
448 -- unnested to avoid deep indentation of code.
450 Loc : constant Source_Ptr := Sloc (Attr);
452 procedure Validate_Component_List
455 Stmts : in out List_Id);
456 -- Process all components and variant parts of component list Comp_List.
457 -- Obj_Id denotes the entity of the validation parameter. All new code
458 -- is added to list Stmts.
460 procedure Validate_Field
463 Cond : in out Node_Id);
464 -- Process component declaration or discriminant specification Field.
465 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
466 -- an "or else" conditional expression which contains the new code (if
469 procedure Validate_Fields
472 Stmts : in out List_Id);
473 -- Process component declarations or discriminant specifications in list
474 -- Fields. Obj_Id denotes the entity of the validation parameter. All
475 -- new code is added to list Stmts.
477 procedure Validate_Variant
480 Alts : in out List_Id);
481 -- Process variant Var. Obj_Id denotes the entity of the validation
482 -- parameter. Alts denotes a list of case statement alternatives which
483 -- contains the new code (if any).
485 procedure Validate_Variant_Part
488 Stmts : in out List_Id);
489 -- Process variant part Var_Part. Obj_Id denotes the entity of the
490 -- validation parameter. All new code is added to list Stmts.
492 -----------------------------
493 -- Validate_Component_List --
494 -----------------------------
496 procedure Validate_Component_List
499 Stmts : in out List_Id)
501 Var_Part : constant Node_Id := Variant_Part (Comp_List);
504 -- Validate all components
508 Fields => Component_Items (Comp_List),
511 -- Validate the variant part
513 if Present (Var_Part) then
514 Validate_Variant_Part
516 Var_Part => Var_Part,
519 end Validate_Component_List;
525 procedure Validate_Field
528 Cond : in out Node_Id)
530 Field_Id : constant Entity_Id := Defining_Entity (Field);
531 Field_Nam : constant Name_Id := Chars (Field_Id);
532 Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
536 -- Do not process internally-generated fields. Note that checking for
537 -- Comes_From_Source is not correct because this will eliminate the
538 -- components within the corresponding record of a protected type.
540 if Nam_In (Field_Nam, Name_uObject,
546 -- Do not process fields without any scalar components
548 elsif not Scalar_Part_Present (Field_Typ) then
551 -- Otherwise the field needs to be validated. Use Make_Identifier
552 -- rather than New_Occurrence_Of to identify the field because the
553 -- wrong entity may be picked up when private types are involved.
556 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
559 if Is_Scalar_Type (Field_Typ) then
560 Attr_Nam := Name_Valid;
562 Attr_Nam := Name_Valid_Scalars;
565 Evolve_Or_Else (Cond,
568 Make_Attribute_Reference (Loc,
570 Make_Selected_Component (Loc,
572 Unchecked_Convert_To (Rec_Typ,
573 New_Occurrence_Of (Obj_Id, Loc)),
574 Selector_Name => Make_Identifier (Loc, Field_Nam)),
575 Attribute_Name => Attr_Nam)));
579 ---------------------
580 -- Validate_Fields --
581 ---------------------
583 procedure Validate_Fields
586 Stmts : in out List_Id)
592 -- Assume that none of the fields are eligible for verification
596 -- Validate all fields
598 Field := First_Non_Pragma (Fields);
599 while Present (Field) loop
605 Next_Non_Pragma (Field);
609 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
610 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
615 if Present (Cond) then
616 Append_New_To (Stmts,
617 Make_Implicit_If_Statement (Attr,
619 Then_Statements => New_List (
620 Make_Simple_Return_Statement (Loc,
621 Expression => New_Occurrence_Of (Standard_False, Loc)))));
625 ----------------------
626 -- Validate_Variant --
627 ----------------------
629 procedure Validate_Variant
632 Alts : in out List_Id)
637 -- Assume that none of the components and variants are eligible for
642 -- Validate components
644 Validate_Component_List
646 Comp_List => Component_List (Var),
649 -- Generate a null statement in case none of the components were
650 -- verified because this will otherwise eliminate an alternative
651 -- from the variant case statement and render the generated code
655 Append_New_To (Stmts, Make_Null_Statement (Loc));
659 -- when Discrete_Choices =>
663 Make_Case_Statement_Alternative (Loc,
665 New_Copy_List_Tree (Discrete_Choices (Var)),
666 Statements => Stmts));
667 end Validate_Variant;
669 ---------------------------
670 -- Validate_Variant_Part --
671 ---------------------------
673 procedure Validate_Variant_Part
676 Stmts : in out List_Id)
678 Vars : constant List_Id := Variants (Var_Part);
683 -- Assume that none of the variants are eligible for verification
689 Var := First_Non_Pragma (Vars);
690 while Present (Var) loop
696 Next_Non_Pragma (Var);
699 -- Even though individual variants may lack eligible components, the
700 -- alternatives must still be generated.
702 pragma Assert (Present (Alts));
705 -- case Rec_Typ (Obj_Id).Discriminant is
706 -- when Discrete_Choices_1 =>
708 -- when Discrete_Choices_N =>
712 Append_New_To (Stmts,
713 Make_Case_Statement (Loc,
715 Make_Selected_Component (Loc,
717 Unchecked_Convert_To (Rec_Typ,
718 New_Occurrence_Of (Obj_Id, Loc)),
719 Selector_Name => New_Copy_Tree (Name (Var_Part))),
720 Alternatives => Alts));
721 end Validate_Variant_Part;
725 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
726 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
734 -- Start of processing for Build_Record_VS_Func
739 -- Use the root type when dealing with a class-wide type
741 if Is_Class_Wide_Type (Typ) then
742 Typ := Root_Type (Typ);
745 Typ_Decl := Declaration_Node (Typ);
746 Typ_Def := Type_Definition (Typ_Decl);
748 -- The components of a derived type are located in the extension part
750 if Nkind (Typ_Def) = N_Derived_Type_Definition then
751 Typ_Ext := Record_Extension_Part (Typ_Def);
753 if Present (Typ_Ext) then
754 Comps := Component_List (Typ_Ext);
759 -- Otherwise the components are available in the definition
762 Comps := Component_List (Typ_Def);
765 -- The code generated by this routine is as follows:
767 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
769 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
770 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
775 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
776 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
781 -- case Discriminant_1 is
783 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
784 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
789 -- case Discriminant_N is
798 -- Assume that the record type lacks eligible components, discriminants,
799 -- and variant parts.
803 -- Validate the discriminants
805 if not Is_Unchecked_Union (Rec_Typ) then
808 Fields => Discriminant_Specifications (Typ_Decl),
812 -- Validate the components and variant parts
814 Validate_Component_List
822 Append_New_To (Stmts,
823 Make_Simple_Return_Statement (Loc,
824 Expression => New_Occurrence_Of (Standard_True, Loc)));
827 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
832 Set_Ekind (Func_Id, E_Function);
833 Set_Is_Internal (Func_Id);
834 Set_Is_Pure (Func_Id);
836 if not Debug_Generated_Code then
837 Set_Debug_Info_Off (Func_Id);
841 Make_Subprogram_Body (Loc,
843 Make_Function_Specification (Loc,
844 Defining_Unit_Name => Func_Id,
845 Parameter_Specifications => New_List (
846 Make_Parameter_Specification (Loc,
847 Defining_Identifier => Obj_Id,
848 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
850 New_Occurrence_Of (Standard_Boolean, Loc)),
851 Declarations => New_List,
852 Handled_Statement_Sequence =>
853 Make_Handled_Sequence_Of_Statements (Loc,
854 Statements => Stmts)),
855 Suppress => Discriminant_Check);
858 end Build_Record_VS_Func;
860 ----------------------------------
861 -- Compile_Stream_Body_In_Scope --
862 ----------------------------------
864 procedure Compile_Stream_Body_In_Scope
870 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
871 Curr : constant Entity_Id := Current_Scope;
872 Install : Boolean := False;
873 Scop : Entity_Id := Scope (Arr);
877 and then not In_Open_Scopes (Scop)
878 and then Ekind (Scop) = E_Package
883 -- The component type may be private, in which case we install its
884 -- full view to compile the subprogram.
886 -- The component type may be private, in which case we install its
887 -- full view to compile the subprogram. We do not do this if the
888 -- type has a Stream_Convert pragma, which indicates that there are
889 -- special stream-processing operations for that type (for example
890 -- Unbounded_String and its wide varieties).
892 Scop := Scope (C_Type);
894 if Is_Private_Type (C_Type)
895 and then Present (Full_View (C_Type))
896 and then not In_Open_Scopes (Scop)
897 and then Ekind (Scop) = E_Package
898 and then No (Get_Stream_Convert_Pragma (C_Type))
904 -- If we are within an instance body, then all visibility has been
905 -- established already and there is no need to install the package.
907 if Install and then not In_Instance_Body then
909 Install_Visible_Declarations (Scop);
910 Install_Private_Declarations (Scop);
912 -- The entities in the package are now visible, but the generated
913 -- stream entity must appear in the current scope (usually an
914 -- enclosing stream function) so that itypes all have their proper
923 Insert_Action (N, Decl);
925 Insert_Action (N, Decl, Suppress => All_Checks);
930 -- Remove extra copy of current scope, and package itself
933 End_Package_Scope (Scop);
935 end Compile_Stream_Body_In_Scope;
937 -----------------------------------
938 -- Expand_Access_To_Protected_Op --
939 -----------------------------------
941 procedure Expand_Access_To_Protected_Op
946 -- The value of the attribute_reference is a record containing two
947 -- fields: an access to the protected object, and an access to the
948 -- subprogram itself. The prefix is a selected component.
950 Loc : constant Source_Ptr := Sloc (N);
952 Btyp : constant Entity_Id := Base_Type (Typ);
955 E_T : constant Entity_Id := Equivalent_Type (Btyp);
956 Acc : constant Entity_Id :=
957 Etype (Next_Component (First_Component (E_T)));
961 -- Start of processing for Expand_Access_To_Protected_Op
964 -- Within the body of the protected type, the prefix designates a local
965 -- operation, and the object is the first parameter of the corresponding
966 -- protected body of the current enclosing operation.
968 if Is_Entity_Name (Pref) then
969 -- All indirect calls are external calls, so must do locking and
970 -- barrier reevaluation, even if the 'Access occurs within the
971 -- protected body. Hence the call to External_Subprogram, as opposed
972 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
973 -- that indirect calls from within the same protected body will
974 -- deadlock, as allowed by RM-9.5.1(8,15,17).
976 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
978 -- Don't traverse the scopes when the attribute occurs within an init
979 -- proc, because we directly use the _init formal of the init proc in
982 Curr := Current_Scope;
983 if not Is_Init_Proc (Curr) then
984 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
986 while Scope (Curr) /= Scope (Entity (Pref)) loop
987 Curr := Scope (Curr);
991 -- In case of protected entries the first formal of its Protected_
992 -- Body_Subprogram is the address of the object.
994 if Ekind (Curr) = E_Entry then
998 (Protected_Body_Subprogram (Curr)), Loc);
1000 -- If the current scope is an init proc, then use the address of the
1001 -- _init formal as the object reference.
1003 elsif Is_Init_Proc (Curr) then
1005 Make_Attribute_Reference (Loc,
1006 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
1007 Attribute_Name => Name_Address);
1009 -- In case of protected subprograms the first formal of its
1010 -- Protected_Body_Subprogram is the object and we get its address.
1014 Make_Attribute_Reference (Loc,
1018 (Protected_Body_Subprogram (Curr)), Loc),
1019 Attribute_Name => Name_Address);
1022 -- Case where the prefix is not an entity name. Find the
1023 -- version of the protected operation to be called from
1024 -- outside the protected object.
1029 (External_Subprogram
1030 (Entity (Selector_Name (Pref))), Loc);
1033 Make_Attribute_Reference (Loc,
1034 Prefix => Relocate_Node (Prefix (Pref)),
1035 Attribute_Name => Name_Address);
1039 Make_Attribute_Reference (Loc,
1041 Attribute_Name => Name_Access);
1043 -- We set the type of the access reference to the already generated
1044 -- access_to_subprogram type, and declare the reference analyzed, to
1045 -- prevent further expansion when the enclosing aggregate is analyzed.
1047 Set_Etype (Sub_Ref, Acc);
1048 Set_Analyzed (Sub_Ref);
1051 Make_Aggregate (Loc,
1052 Expressions => New_List (Obj_Ref, Sub_Ref));
1054 -- Sub_Ref has been marked as analyzed, but we still need to make sure
1055 -- Sub is correctly frozen.
1057 Freeze_Before (N, Entity (Sub));
1060 Analyze_And_Resolve (N, E_T);
1062 -- For subsequent analysis, the node must retain its type. The backend
1063 -- will replace it with the equivalent type where needed.
1066 end Expand_Access_To_Protected_Op;
1068 --------------------------
1069 -- Expand_Fpt_Attribute --
1070 --------------------------
1072 procedure Expand_Fpt_Attribute
1078 Loc : constant Source_Ptr := Sloc (N);
1079 Typ : constant Entity_Id := Etype (N);
1083 -- The function name is the selected component Attr_xxx.yyy where
1084 -- Attr_xxx is the package name, and yyy is the argument Nam.
1086 -- Note: it would be more usual to have separate RE entries for each
1087 -- of the entities in the Fat packages, but first they have identical
1088 -- names (so we would have to have lots of renaming declarations to
1089 -- meet the normal RE rule of separate names for all runtime entities),
1090 -- and second there would be an awful lot of them.
1093 Make_Selected_Component (Loc,
1094 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
1095 Selector_Name => Make_Identifier (Loc, Nam));
1097 -- The generated call is given the provided set of parameters, and then
1098 -- wrapped in a conversion which converts the result to the target type
1099 -- We use the base type as the target because a range check may be
1103 Unchecked_Convert_To (Base_Type (Etype (N)),
1104 Make_Function_Call (Loc,
1106 Parameter_Associations => Args)));
1108 Analyze_And_Resolve (N, Typ);
1109 end Expand_Fpt_Attribute;
1111 ----------------------------
1112 -- Expand_Fpt_Attribute_R --
1113 ----------------------------
1115 -- The single argument is converted to its root type to call the
1116 -- appropriate runtime function, with the actual call being built
1117 -- by Expand_Fpt_Attribute
1119 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
1120 E1 : constant Node_Id := First (Expressions (N));
1124 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1125 Expand_Fpt_Attribute
1126 (N, Pkg, Attribute_Name (N),
1127 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
1128 end Expand_Fpt_Attribute_R;
1130 -----------------------------
1131 -- Expand_Fpt_Attribute_RI --
1132 -----------------------------
1134 -- The first argument is converted to its root type and the second
1135 -- argument is converted to standard long long integer to call the
1136 -- appropriate runtime function, with the actual call being built
1137 -- by Expand_Fpt_Attribute
1139 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
1140 E1 : constant Node_Id := First (Expressions (N));
1143 E2 : constant Node_Id := Next (E1);
1145 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1146 Expand_Fpt_Attribute
1147 (N, Pkg, Attribute_Name (N),
1149 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
1150 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
1151 end Expand_Fpt_Attribute_RI;
1153 -----------------------------
1154 -- Expand_Fpt_Attribute_RR --
1155 -----------------------------
1157 -- The two arguments are converted to their root types to call the
1158 -- appropriate runtime function, with the actual call being built
1159 -- by Expand_Fpt_Attribute
1161 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
1162 E1 : constant Node_Id := First (Expressions (N));
1163 E2 : constant Node_Id := Next (E1);
1168 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1169 Expand_Fpt_Attribute
1170 (N, Pkg, Attribute_Name (N),
1172 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
1173 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
1174 end Expand_Fpt_Attribute_RR;
1176 ---------------------------------
1177 -- Expand_Loop_Entry_Attribute --
1178 ---------------------------------
1180 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
1181 procedure Build_Conditional_Block
1184 Loop_Stmt : Node_Id;
1185 If_Stmt : out Node_Id;
1186 Blk_Stmt : out Node_Id);
1187 -- Create a block Blk_Stmt with an empty declarative list and a single
1188 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1189 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1191 function Is_Array_Iteration (N : Node_Id) return Boolean;
1192 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1195 -----------------------------
1196 -- Build_Conditional_Block --
1197 -----------------------------
1199 procedure Build_Conditional_Block
1202 Loop_Stmt : Node_Id;
1203 If_Stmt : out Node_Id;
1204 Blk_Stmt : out Node_Id)
1207 -- Do not reanalyze the original loop statement because it is simply
1210 Set_Analyzed (Loop_Stmt);
1213 Make_Block_Statement (Loc,
1214 Declarations => New_List,
1215 Handled_Statement_Sequence =>
1216 Make_Handled_Sequence_Of_Statements (Loc,
1217 Statements => New_List (Loop_Stmt)));
1219 if Present (Cond) then
1221 Make_If_Statement (Loc,
1223 Then_Statements => New_List (Blk_Stmt));
1227 end Build_Conditional_Block;
1229 ------------------------
1230 -- Is_Array_Iteration --
1231 ------------------------
1233 function Is_Array_Iteration (N : Node_Id) return Boolean is
1234 Stmt : constant Node_Id := Original_Node (N);
1238 if Nkind (Stmt) = N_Loop_Statement
1239 and then Present (Iteration_Scheme (Stmt))
1240 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1242 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1245 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1249 end Is_Array_Iteration;
1253 Pref : constant Node_Id := Prefix (N);
1254 Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
1255 Exprs : constant List_Id := Expressions (N);
1257 Blk : Node_Id := Empty;
1259 Installed : Boolean;
1261 Loop_Id : Entity_Id;
1262 Loop_Stmt : Node_Id;
1263 Result : Node_Id := Empty;
1265 Temp_Decl : Node_Id;
1266 Temp_Id : Entity_Id;
1268 -- Start of processing for Expand_Loop_Entry_Attribute
1271 -- Step 1: Find the related loop
1273 -- The loop label variant of attribute 'Loop_Entry already has all the
1274 -- information in its expression.
1276 if Present (Exprs) then
1277 Loop_Id := Entity (First (Exprs));
1278 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1280 -- Climb the parent chain to find the nearest enclosing loop. Skip
1281 -- all internally generated loops for quantified expressions and for
1282 -- element iterators over multidimensional arrays because the pragma
1283 -- applies to source loop.
1287 while Present (Loop_Stmt) loop
1288 if Nkind (Loop_Stmt) = N_Loop_Statement
1289 and then Nkind (Original_Node (Loop_Stmt)) = N_Loop_Statement
1290 and then Comes_From_Source (Original_Node (Loop_Stmt))
1295 Loop_Stmt := Parent (Loop_Stmt);
1298 Loop_Id := Entity (Identifier (Loop_Stmt));
1301 Loc := Sloc (Loop_Stmt);
1303 -- Step 2: Transform the loop
1305 -- The loop has already been transformed during the expansion of a prior
1306 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1308 if Has_Loop_Entry_Attributes (Loop_Id) then
1310 -- When the related loop name appears as the argument of attribute
1311 -- Loop_Entry, the corresponding label construct is the generated
1312 -- block statement. This is because the expander reuses the label.
1314 if Nkind (Loop_Stmt) = N_Block_Statement then
1315 Decls := Declarations (Loop_Stmt);
1317 -- In all other cases, the loop must appear in the handled sequence
1318 -- of statements of the generated block.
1322 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1324 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1326 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1329 -- Transform the loop into a conditional block
1332 Set_Has_Loop_Entry_Attributes (Loop_Id);
1333 Scheme := Iteration_Scheme (Loop_Stmt);
1335 -- Infinite loops are transformed into:
1338 -- Temp1 : constant <type of Pref1> := <Pref1>;
1340 -- TempN : constant <type of PrefN> := <PrefN>;
1343 -- <original source statements with attribute rewrites>
1348 Build_Conditional_Block (Loc,
1350 Loop_Stmt => Relocate_Node (Loop_Stmt),
1356 -- While loops are transformed into:
1358 -- function Fnn return Boolean is
1360 -- <condition actions>
1361 -- return <condition>;
1366 -- Temp1 : constant <type of Pref1> := <Pref1>;
1368 -- TempN : constant <type of PrefN> := <PrefN>;
1371 -- <original source statements with attribute rewrites>
1372 -- exit when not Fnn;
1377 -- Note that loops over iterators and containers are already
1378 -- converted into while loops.
1380 elsif Present (Condition (Scheme)) then
1382 Func_Decl : Node_Id;
1383 Func_Id : Entity_Id;
1387 -- Wrap the condition of the while loop in a Boolean function.
1388 -- This avoids the duplication of the same code which may lead
1389 -- to gigi issues with respect to multiple declaration of the
1390 -- same entity in the presence of side effects or checks. Note
1391 -- that the condition actions must also be relocated to the
1392 -- wrapping function.
1395 -- <condition actions>
1396 -- return <condition>;
1398 if Present (Condition_Actions (Scheme)) then
1399 Stmts := Condition_Actions (Scheme);
1405 Make_Simple_Return_Statement (Loc,
1406 Expression => Relocate_Node (Condition (Scheme))));
1409 -- function Fnn return Boolean is
1414 Func_Id := Make_Temporary (Loc, 'F');
1416 Make_Subprogram_Body (Loc,
1418 Make_Function_Specification (Loc,
1419 Defining_Unit_Name => Func_Id,
1420 Result_Definition =>
1421 New_Occurrence_Of (Standard_Boolean, Loc)),
1422 Declarations => Empty_List,
1423 Handled_Statement_Sequence =>
1424 Make_Handled_Sequence_Of_Statements (Loc,
1425 Statements => Stmts));
1427 -- The function is inserted before the related loop. Make sure
1428 -- to analyze it in the context of the loop's enclosing scope.
1430 Push_Scope (Scope (Loop_Id));
1431 Insert_Action (Loop_Stmt, Func_Decl);
1434 -- Transform the original while loop into an infinite loop
1435 -- where the last statement checks the negated condition. This
1436 -- placement ensures that the condition will not be evaluated
1437 -- twice on the first iteration.
1439 Set_Iteration_Scheme (Loop_Stmt, Empty);
1443 -- exit when not Fnn;
1445 Append_To (Statements (Loop_Stmt),
1446 Make_Exit_Statement (Loc,
1450 Make_Function_Call (Loc,
1451 Name => New_Occurrence_Of (Func_Id, Loc)))));
1453 Build_Conditional_Block (Loc,
1455 Make_Function_Call (Loc,
1456 Name => New_Occurrence_Of (Func_Id, Loc)),
1457 Loop_Stmt => Relocate_Node (Loop_Stmt),
1462 -- Ada 2012 iteration over an array is transformed into:
1464 -- if <Array_Nam>'Length (1) > 0
1465 -- and then <Array_Nam>'Length (N) > 0
1468 -- Temp1 : constant <type of Pref1> := <Pref1>;
1470 -- TempN : constant <type of PrefN> := <PrefN>;
1472 -- for X in ... loop -- multiple loops depending on dims
1473 -- <original source statements with attribute rewrites>
1478 elsif Is_Array_Iteration (Loop_Stmt) then
1480 Array_Nam : constant Entity_Id :=
1481 Entity (Name (Iterator_Specification
1482 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1483 Num_Dims : constant Pos :=
1484 Number_Dimensions (Etype (Array_Nam));
1485 Cond : Node_Id := Empty;
1489 -- Generate a check which determines whether all dimensions of
1490 -- the array are non-null.
1492 for Dim in 1 .. Num_Dims loop
1496 Make_Attribute_Reference (Loc,
1497 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1498 Attribute_Name => Name_Length,
1499 Expressions => New_List (
1500 Make_Integer_Literal (Loc, Dim))),
1502 Make_Integer_Literal (Loc, 0));
1510 Right_Opnd => Check);
1514 Build_Conditional_Block (Loc,
1516 Loop_Stmt => Relocate_Node (Loop_Stmt),
1521 -- For loops are transformed into:
1523 -- if <Low> <= <High> then
1525 -- Temp1 : constant <type of Pref1> := <Pref1>;
1527 -- TempN : constant <type of PrefN> := <PrefN>;
1529 -- for <Def_Id> in <Low> .. <High> loop
1530 -- <original source statements with attribute rewrites>
1535 elsif Present (Loop_Parameter_Specification (Scheme)) then
1537 Loop_Spec : constant Node_Id :=
1538 Loop_Parameter_Specification (Scheme);
1543 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1545 -- When the loop iterates over a subtype indication with a
1546 -- range, use the low and high bounds of the subtype itself.
1548 if Nkind (Subt_Def) = N_Subtype_Indication then
1549 Subt_Def := Scalar_Range (Etype (Subt_Def));
1552 pragma Assert (Nkind (Subt_Def) = N_Range);
1559 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1560 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1562 Build_Conditional_Block (Loc,
1564 Loop_Stmt => Relocate_Node (Loop_Stmt),
1570 Decls := Declarations (Blk);
1573 -- Step 3: Create a constant to capture the value of the prefix at the
1574 -- entry point into the loop.
1576 Temp_Id := Make_Temporary (Loc, 'P');
1578 -- Preserve the tag of the prefix by offering a specific view of the
1579 -- class-wide version of the prefix.
1581 if Is_Tagged_Type (Base_Typ) then
1582 Tagged_Case : declare
1583 CW_Temp : Entity_Id;
1588 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1590 CW_Temp := Make_Temporary (Loc, 'T');
1591 CW_Typ := Class_Wide_Type (Base_Typ);
1594 Make_Object_Declaration (Loc,
1595 Defining_Identifier => CW_Temp,
1596 Constant_Present => True,
1597 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1599 Convert_To (CW_Typ, Relocate_Node (Pref)));
1600 Append_To (Decls, Aux_Decl);
1603 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1606 Make_Object_Renaming_Declaration (Loc,
1607 Defining_Identifier => Temp_Id,
1608 Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
1610 Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
1611 Append_To (Decls, Temp_Decl);
1617 Untagged_Case : declare
1618 Temp_Expr : Node_Id;
1623 -- Generate a nominal type for the constant when the prefix is of
1624 -- a constrained type. This is achieved by setting the Etype of
1625 -- the relocated prefix to its base type. Since the prefix is now
1626 -- the initialization expression of the constant, its freezing
1627 -- will produce a proper nominal type.
1629 Temp_Expr := Relocate_Node (Pref);
1630 Set_Etype (Temp_Expr, Base_Typ);
1633 -- Temp : constant Base_Typ := Pref;
1636 Make_Object_Declaration (Loc,
1637 Defining_Identifier => Temp_Id,
1638 Constant_Present => True,
1639 Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
1640 Expression => Temp_Expr);
1641 Append_To (Decls, Temp_Decl);
1645 -- Step 4: Analyze all bits
1647 Installed := Current_Scope = Scope (Loop_Id);
1649 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1650 -- associated loop, ensure the proper visibility for analysis.
1652 if not Installed then
1653 Push_Scope (Scope (Loop_Id));
1656 -- The analysis of the conditional block takes care of the constant
1659 if Present (Result) then
1660 Rewrite (Loop_Stmt, Result);
1661 Analyze (Loop_Stmt);
1663 -- The conditional block was analyzed when a previous 'Loop_Entry was
1664 -- expanded. There is no point in reanalyzing the block, simply analyze
1665 -- the declaration of the constant.
1668 if Present (Aux_Decl) then
1672 Analyze (Temp_Decl);
1675 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1678 if not Installed then
1681 end Expand_Loop_Entry_Attribute;
1683 ------------------------------
1684 -- Expand_Min_Max_Attribute --
1685 ------------------------------
1687 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1689 -- Min and Max are handled by the back end (except that static cases
1690 -- have already been evaluated during semantic processing, although the
1691 -- back end should not count on this). The one bit of special processing
1692 -- required in the normal case is that these two attributes typically
1693 -- generate conditionals in the code, so check the relevant restriction.
1695 Check_Restriction (No_Implicit_Conditionals, N);
1697 -- In Modify_Tree_For_C mode, we rewrite as an if expression (unless it
1700 if Modify_Tree_For_C
1701 and then not Is_Integer_Type (Etype (N))
1702 and then not Is_Enumeration_Type (Etype (N))
1703 and then not Is_Fixed_Point_Type (Etype (N))
1704 and then not Is_Floating_Point_Type (Etype (N))
1707 Loc : constant Source_Ptr := Sloc (N);
1708 Typ : constant Entity_Id := Etype (N);
1709 Expr : constant Node_Id := First (Expressions (N));
1710 Left : constant Node_Id := Relocate_Node (Expr);
1711 Right : constant Node_Id := Relocate_Node (Next (Expr));
1713 function Make_Compare (Left, Right : Node_Id) return Node_Id;
1714 -- Returns Left >= Right for Max, Left <= Right for Min
1720 function Make_Compare (Left, Right : Node_Id) return Node_Id is
1722 if Attribute_Name (N) = Name_Max then
1726 Right_Opnd => Right);
1731 Right_Opnd => Right);
1735 -- Start of processing for Min_Max
1738 -- If both Left and Right are side effect free, then we can just
1739 -- use Duplicate_Expr to duplicate the references and return
1741 -- (if Left >=|<= Right then Left else Right)
1743 if Side_Effect_Free (Left) and then Side_Effect_Free (Right) then
1745 Make_If_Expression (Loc,
1746 Expressions => New_List (
1747 Make_Compare (Left, Right),
1748 Duplicate_Subexpr_No_Checks (Left),
1749 Duplicate_Subexpr_No_Checks (Right))));
1751 -- Otherwise we generate declarations to capture the values.
1753 -- The translation is
1756 -- T1 : constant typ := Left;
1757 -- T2 : constant typ := Right;
1759 -- (if T1 >=|<= T2 then T1 else T2)
1764 T1 : constant Entity_Id := Make_Temporary (Loc, 'T', Left);
1765 T2 : constant Entity_Id := Make_Temporary (Loc, 'T', Right);
1769 Make_Expression_With_Actions (Loc,
1770 Actions => New_List (
1771 Make_Object_Declaration (Loc,
1772 Defining_Identifier => T1,
1773 Constant_Present => True,
1774 Object_Definition =>
1775 New_Occurrence_Of (Etype (Left), Loc),
1776 Expression => Relocate_Node (Left)),
1778 Make_Object_Declaration (Loc,
1779 Defining_Identifier => T2,
1780 Constant_Present => True,
1781 Object_Definition =>
1782 New_Occurrence_Of (Etype (Right), Loc),
1783 Expression => Relocate_Node (Right))),
1786 Make_If_Expression (Loc,
1787 Expressions => New_List (
1789 (New_Occurrence_Of (T1, Loc),
1790 New_Occurrence_Of (T2, Loc)),
1791 New_Occurrence_Of (T1, Loc),
1792 New_Occurrence_Of (T2, Loc)))));
1796 Analyze_And_Resolve (N, Typ);
1799 end Expand_Min_Max_Attribute;
1801 ----------------------------------
1802 -- Expand_N_Attribute_Reference --
1803 ----------------------------------
1805 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1806 Loc : constant Source_Ptr := Sloc (N);
1807 Typ : constant Entity_Id := Etype (N);
1808 Btyp : constant Entity_Id := Base_Type (Typ);
1809 Pref : constant Node_Id := Prefix (N);
1810 Ptyp : constant Entity_Id := Etype (Pref);
1811 Exprs : constant List_Id := Expressions (N);
1812 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1814 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1815 -- Rewrites a stream attribute for Read, Write or Output with the
1816 -- procedure call. Pname is the entity for the procedure to call.
1818 ------------------------------
1819 -- Rewrite_Stream_Proc_Call --
1820 ------------------------------
1822 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1823 Item : constant Node_Id := Next (First (Exprs));
1824 Item_Typ : constant Entity_Id := Etype (Item);
1825 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1826 Formal_Typ : constant Entity_Id := Etype (Formal);
1827 Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
1830 -- The expansion depends on Item, the second actual, which is
1831 -- the object being streamed in or out.
1833 -- If the item is a component of a packed array type, and
1834 -- a conversion is needed on exit, we introduce a temporary to
1835 -- hold the value, because otherwise the packed reference will
1836 -- not be properly expanded.
1838 if Nkind (Item) = N_Indexed_Component
1839 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1840 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1844 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1850 Make_Object_Declaration (Loc,
1851 Defining_Identifier => Temp,
1852 Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
1853 Set_Etype (Temp, Formal_Typ);
1856 Make_Assignment_Statement (Loc,
1857 Name => New_Copy_Tree (Item),
1859 Unchecked_Convert_To
1860 (Item_Typ, New_Occurrence_Of (Temp, Loc)));
1862 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1866 Make_Procedure_Call_Statement (Loc,
1867 Name => New_Occurrence_Of (Pname, Loc),
1868 Parameter_Associations => Exprs),
1871 Rewrite (N, Make_Null_Statement (Loc));
1876 -- For the class-wide dispatching cases, and for cases in which
1877 -- the base type of the second argument matches the base type of
1878 -- the corresponding formal parameter (that is to say the stream
1879 -- operation is not inherited), we are all set, and can use the
1880 -- argument unchanged.
1882 if not Is_Class_Wide_Type (Entity (Pref))
1883 and then not Is_Class_Wide_Type (Etype (Item))
1884 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1886 -- Perform a view conversion when either the argument or the
1887 -- formal parameter are of a private type.
1889 if Is_Private_Type (Base_Type (Formal_Typ))
1890 or else Is_Private_Type (Base_Type (Item_Typ))
1893 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1895 -- Otherwise perform a regular type conversion to ensure that all
1896 -- relevant checks are installed.
1899 Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
1902 -- For untagged derived types set Assignment_OK, to prevent
1903 -- copies from being created when the unchecked conversion
1904 -- is expanded (which would happen in Remove_Side_Effects
1905 -- if Expand_N_Unchecked_Conversion were allowed to call
1906 -- Force_Evaluation). The copy could violate Ada semantics in
1907 -- cases such as an actual that is an out parameter. Note that
1908 -- this approach is also used in exp_ch7 for calls to controlled
1909 -- type operations to prevent problems with actuals wrapped in
1910 -- unchecked conversions.
1912 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1913 Set_Assignment_OK (Item);
1917 -- The stream operation to call may be a renaming created by an
1918 -- attribute definition clause, and may not be frozen yet. Ensure
1919 -- that it has the necessary extra formals.
1921 if not Is_Frozen (Pname) then
1922 Create_Extra_Formals (Pname);
1925 -- And now rewrite the call
1928 Make_Procedure_Call_Statement (Loc,
1929 Name => New_Occurrence_Of (Pname, Loc),
1930 Parameter_Associations => Exprs));
1933 end Rewrite_Stream_Proc_Call;
1935 -- Start of processing for Expand_N_Attribute_Reference
1938 -- Do required validity checking, if enabled. Do not apply check to
1939 -- output parameters of an Asm instruction, since the value of this
1940 -- is not set till after the attribute has been elaborated, and do
1941 -- not apply the check to the arguments of a 'Read or 'Input attribute
1942 -- reference since the scalar argument is an OUT scalar.
1944 if Validity_Checks_On and then Validity_Check_Operands
1945 and then Id /= Attribute_Asm_Output
1946 and then Id /= Attribute_Read
1947 and then Id /= Attribute_Input
1952 Expr := First (Expressions (N));
1953 while Present (Expr) loop
1954 Ensure_Valid (Expr);
1960 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1961 -- place function, then a temporary return object needs to be created
1962 -- and access to it must be passed to the function.
1964 if Is_Build_In_Place_Function_Call (Pref) then
1966 -- If attribute is 'Old, the context is a postcondition, and
1967 -- the temporary must go in the corresponding subprogram, not
1968 -- the postcondition function or any created blocks, as when
1969 -- the attribute appears in a quantified expression. This is
1970 -- handled below in the expansion of the attribute.
1972 if Attribute_Name (Parent (Pref)) = Name_Old then
1975 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1978 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
1979 -- containing build-in-place function calls whose returned object covers
1982 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
1983 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
1986 -- If prefix is a protected type name, this is a reference to the
1987 -- current instance of the type. For a component definition, nothing
1988 -- to do (expansion will occur in the init proc). In other contexts,
1989 -- rewrite into reference to current instance.
1991 if Is_Protected_Self_Reference (Pref)
1993 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1994 N_Discriminant_Association)
1995 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1996 N_Component_Definition)
1998 -- No action needed for these attributes since the current instance
1999 -- will be rewritten to be the name of the _object parameter
2000 -- associated with the enclosing protected subprogram (see below).
2002 and then Id /= Attribute_Access
2003 and then Id /= Attribute_Unchecked_Access
2004 and then Id /= Attribute_Unrestricted_Access
2006 Rewrite (Pref, Concurrent_Ref (Pref));
2010 -- Remaining processing depends on specific attribute
2012 -- Note: individual sections of the following case statement are
2013 -- allowed to assume there is no code after the case statement, and
2014 -- are legitimately allowed to execute return statements if they have
2015 -- nothing more to do.
2019 -- Attributes related to Ada 2012 iterators
2021 when Attribute_Constant_Indexing
2022 | Attribute_Default_Iterator
2023 | Attribute_Implicit_Dereference
2024 | Attribute_Iterable
2025 | Attribute_Iterator_Element
2026 | Attribute_Variable_Indexing
2030 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
2031 -- were already rejected by the parser. Thus they shouldn't appear here.
2033 when Internal_Attribute_Id =>
2034 raise Program_Error;
2040 when Attribute_Access
2041 | Attribute_Unchecked_Access
2042 | Attribute_Unrestricted_Access
2044 Access_Cases : declare
2045 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
2046 Btyp_DDT : Entity_Id;
2048 function Enclosing_Object (N : Node_Id) return Node_Id;
2049 -- If N denotes a compound name (selected component, indexed
2050 -- component, or slice), returns the name of the outermost such
2051 -- enclosing object. Otherwise returns N. If the object is a
2052 -- renaming, then the renamed object is returned.
2054 ----------------------
2055 -- Enclosing_Object --
2056 ----------------------
2058 function Enclosing_Object (N : Node_Id) return Node_Id is
2063 while Nkind_In (Obj_Name, N_Selected_Component,
2064 N_Indexed_Component,
2067 Obj_Name := Prefix (Obj_Name);
2070 return Get_Referenced_Object (Obj_Name);
2071 end Enclosing_Object;
2073 -- Local declarations
2075 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
2077 -- Start of processing for Access_Cases
2080 Btyp_DDT := Designated_Type (Btyp);
2082 -- Handle designated types that come from the limited view
2084 if From_Limited_With (Btyp_DDT)
2085 and then Has_Non_Limited_View (Btyp_DDT)
2087 Btyp_DDT := Non_Limited_View (Btyp_DDT);
2090 -- In order to improve the text of error messages, the designated
2091 -- type of access-to-subprogram itypes is set by the semantics as
2092 -- the associated subprogram entity (see sem_attr). Now we replace
2093 -- such node with the proper E_Subprogram_Type itype.
2095 if Id = Attribute_Unrestricted_Access
2096 and then Is_Subprogram (Directly_Designated_Type (Typ))
2098 -- The following conditions ensure that this special management
2099 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2100 -- At this stage other cases in which the designated type is
2101 -- still a subprogram (instead of an E_Subprogram_Type) are
2102 -- wrong because the semantics must have overridden the type of
2103 -- the node with the type imposed by the context.
2105 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
2106 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
2108 Set_Etype (N, RTE (RE_Prim_Ptr));
2112 Subp : constant Entity_Id :=
2113 Directly_Designated_Type (Typ);
2115 Extra : Entity_Id := Empty;
2116 New_Formal : Entity_Id;
2117 Old_Formal : Entity_Id := First_Formal (Subp);
2118 Subp_Typ : Entity_Id;
2121 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
2122 Set_Etype (Subp_Typ, Etype (Subp));
2123 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
2125 if Present (Old_Formal) then
2126 New_Formal := New_Copy (Old_Formal);
2127 Set_First_Entity (Subp_Typ, New_Formal);
2130 Set_Scope (New_Formal, Subp_Typ);
2131 Etyp := Etype (New_Formal);
2133 -- Handle itypes. There is no need to duplicate
2134 -- here the itypes associated with record types
2135 -- (i.e the implicit full view of private types).
2138 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
2140 Extra := New_Copy (Etyp);
2141 Set_Parent (Extra, New_Formal);
2142 Set_Etype (New_Formal, Extra);
2143 Set_Scope (Extra, Subp_Typ);
2146 Extra := New_Formal;
2147 Next_Formal (Old_Formal);
2148 exit when No (Old_Formal);
2150 Link_Entities (New_Formal, New_Copy (Old_Formal));
2151 Next_Entity (New_Formal);
2154 Unlink_Next_Entity (New_Formal);
2155 Set_Last_Entity (Subp_Typ, Extra);
2158 -- Now that the explicit formals have been duplicated,
2159 -- any extra formals needed by the subprogram must be
2162 if Present (Extra) then
2163 Set_Extra_Formal (Extra, Empty);
2166 Create_Extra_Formals (Subp_Typ);
2167 Set_Directly_Designated_Type (Typ, Subp_Typ);
2172 if Is_Access_Protected_Subprogram_Type (Btyp) then
2173 Expand_Access_To_Protected_Op (N, Pref, Typ);
2175 -- If prefix is a type name, this is a reference to the current
2176 -- instance of the type, within its initialization procedure.
2178 elsif Is_Entity_Name (Pref)
2179 and then Is_Type (Entity (Pref))
2186 -- If the current instance name denotes a task type, then
2187 -- the access attribute is rewritten to be the name of the
2188 -- "_task" parameter associated with the task type's task
2189 -- procedure. An unchecked conversion is applied to ensure
2190 -- a type match in cases of expander-generated calls (e.g.
2193 if Is_Task_Type (Entity (Pref)) then
2195 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
2196 while Present (Formal) loop
2197 exit when Chars (Formal) = Name_uTask;
2198 Next_Entity (Formal);
2201 pragma Assert (Present (Formal));
2204 Unchecked_Convert_To (Typ,
2205 New_Occurrence_Of (Formal, Loc)));
2208 elsif Is_Protected_Type (Entity (Pref)) then
2210 -- No action needed for current instance located in a
2211 -- component definition (expansion will occur in the
2214 if Is_Protected_Type (Current_Scope) then
2217 -- If the current instance reference is located in a
2218 -- protected subprogram or entry then rewrite the access
2219 -- attribute to be the name of the "_object" parameter.
2220 -- An unchecked conversion is applied to ensure a type
2221 -- match in cases of expander-generated calls (e.g. init
2224 -- The code may be nested in a block, so find enclosing
2225 -- scope that is a protected operation.
2232 Subp := Current_Scope;
2233 while Ekind_In (Subp, E_Loop, E_Block) loop
2234 Subp := Scope (Subp);
2239 (Protected_Body_Subprogram (Subp));
2241 -- For a protected subprogram the _Object parameter
2242 -- is the protected record, so we create an access
2243 -- to it. The _Object parameter of an entry is an
2246 if Ekind (Subp) = E_Entry then
2248 Unchecked_Convert_To (Typ,
2249 New_Occurrence_Of (Formal, Loc)));
2254 Unchecked_Convert_To (Typ,
2255 Make_Attribute_Reference (Loc,
2256 Attribute_Name => Name_Unrestricted_Access,
2258 New_Occurrence_Of (Formal, Loc))));
2259 Analyze_And_Resolve (N);
2264 -- The expression must appear in a default expression,
2265 -- (which in the initialization procedure is the right-hand
2266 -- side of an assignment), and not in a discriminant
2271 while Present (Par) loop
2272 exit when Nkind (Par) = N_Assignment_Statement;
2274 if Nkind (Par) = N_Component_Declaration then
2278 Par := Parent (Par);
2281 if Present (Par) then
2283 Make_Attribute_Reference (Loc,
2284 Prefix => Make_Identifier (Loc, Name_uInit),
2285 Attribute_Name => Attribute_Name (N)));
2287 Analyze_And_Resolve (N, Typ);
2292 -- If the prefix of an Access attribute is a dereference of an
2293 -- access parameter (or a renaming of such a dereference, or a
2294 -- subcomponent of such a dereference) and the context is a
2295 -- general access type (including the type of an object or
2296 -- component with an access_definition, but not the anonymous
2297 -- type of an access parameter or access discriminant), then
2298 -- apply an accessibility check to the access parameter. We used
2299 -- to rewrite the access parameter as a type conversion, but that
2300 -- could only be done if the immediate prefix of the Access
2301 -- attribute was the dereference, and didn't handle cases where
2302 -- the attribute is applied to a subcomponent of the dereference,
2303 -- since there's generally no available, appropriate access type
2304 -- to convert to in that case. The attribute is passed as the
2305 -- point to insert the check, because the access parameter may
2306 -- come from a renaming, possibly in a different scope, and the
2307 -- check must be associated with the attribute itself.
2309 elsif Id = Attribute_Access
2310 and then Nkind (Enc_Object) = N_Explicit_Dereference
2311 and then Is_Entity_Name (Prefix (Enc_Object))
2312 and then (Ekind (Btyp) = E_General_Access_Type
2313 or else Is_Local_Anonymous_Access (Btyp))
2314 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2315 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2316 = E_Anonymous_Access_Type
2317 and then Present (Extra_Accessibility
2318 (Entity (Prefix (Enc_Object))))
2320 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2322 -- Ada 2005 (AI-251): If the designated type is an interface we
2323 -- add an implicit conversion to force the displacement of the
2324 -- pointer to reference the secondary dispatch table.
2326 elsif Is_Interface (Btyp_DDT)
2327 and then (Comes_From_Source (N)
2328 or else Comes_From_Source (Ref_Object)
2329 or else (Nkind (Ref_Object) in N_Has_Chars
2330 and then Chars (Ref_Object) = Name_uInit))
2332 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2334 -- No implicit conversion required if types match, or if
2335 -- the prefix is the class_wide_type of the interface. In
2336 -- either case passing an object of the interface type has
2337 -- already set the pointer correctly.
2339 if Btyp_DDT = Etype (Ref_Object)
2340 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2342 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2347 Rewrite (Prefix (N),
2348 Convert_To (Btyp_DDT,
2349 New_Copy_Tree (Prefix (N))));
2351 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2354 -- When the object is an explicit dereference, convert the
2355 -- dereference's prefix.
2359 Obj_DDT : constant Entity_Id :=
2361 (Directly_Designated_Type
2362 (Etype (Prefix (Ref_Object))));
2364 -- No implicit conversion required if designated types
2367 if Obj_DDT /= Btyp_DDT
2368 and then not (Is_Class_Wide_Type (Obj_DDT)
2369 and then Etype (Obj_DDT) = Btyp_DDT)
2373 New_Copy_Tree (Prefix (Ref_Object))));
2374 Analyze_And_Resolve (N, Typ);
2385 -- Transforms 'Adjacent into a call to the floating-point attribute
2386 -- function Adjacent in Fat_xxx (where xxx is the root type)
2388 when Attribute_Adjacent =>
2389 Expand_Fpt_Attribute_RR (N);
2395 when Attribute_Address => Address : declare
2396 Task_Proc : Entity_Id;
2399 -- If the prefix is a task or a task type, the useful address is that
2400 -- of the procedure for the task body, i.e. the actual program unit.
2401 -- We replace the original entity with that of the procedure.
2403 if Is_Entity_Name (Pref)
2404 and then Is_Task_Type (Entity (Pref))
2406 Task_Proc := Next_Entity (Root_Type (Ptyp));
2408 while Present (Task_Proc) loop
2409 exit when Ekind (Task_Proc) = E_Procedure
2410 and then Etype (First_Formal (Task_Proc)) =
2411 Corresponding_Record_Type (Ptyp);
2412 Next_Entity (Task_Proc);
2415 if Present (Task_Proc) then
2416 Set_Entity (Pref, Task_Proc);
2417 Set_Etype (Pref, Etype (Task_Proc));
2420 -- Similarly, the address of a protected operation is the address
2421 -- of the corresponding protected body, regardless of the protected
2422 -- object from which it is selected.
2424 elsif Nkind (Pref) = N_Selected_Component
2425 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2426 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2430 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2432 elsif Nkind (Pref) = N_Explicit_Dereference
2433 and then Ekind (Ptyp) = E_Subprogram_Type
2434 and then Convention (Ptyp) = Convention_Protected
2436 -- The prefix is be a dereference of an access_to_protected_
2437 -- subprogram. The desired address is the second component of
2438 -- the record that represents the access.
2441 Addr : constant Entity_Id := Etype (N);
2442 Ptr : constant Node_Id := Prefix (Pref);
2443 T : constant Entity_Id :=
2444 Equivalent_Type (Base_Type (Etype (Ptr)));
2448 Unchecked_Convert_To (Addr,
2449 Make_Selected_Component (Loc,
2450 Prefix => Unchecked_Convert_To (T, Ptr),
2451 Selector_Name => New_Occurrence_Of (
2452 Next_Entity (First_Entity (T)), Loc))));
2454 Analyze_And_Resolve (N, Addr);
2457 -- Ada 2005 (AI-251): Class-wide interface objects are always
2458 -- "displaced" to reference the tag associated with the interface
2459 -- type. In order to obtain the real address of such objects we
2460 -- generate a call to a run-time subprogram that returns the base
2461 -- address of the object.
2463 -- This processing is not needed in the VM case, where dispatching
2464 -- issues are taken care of by the virtual machine.
2466 elsif Is_Class_Wide_Type (Ptyp)
2467 and then Is_Interface (Underlying_Type (Ptyp))
2468 and then Tagged_Type_Expansion
2469 and then not (Nkind (Pref) in N_Has_Entity
2470 and then Is_Subprogram (Entity (Pref)))
2473 Make_Function_Call (Loc,
2474 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2475 Parameter_Associations => New_List (
2476 Relocate_Node (N))));
2481 -- Deal with packed array reference, other cases are handled by
2484 if Involves_Packed_Array_Reference (Pref) then
2485 Expand_Packed_Address_Reference (N);
2493 when Attribute_Alignment => Alignment : declare
2497 -- For class-wide types, X'Class'Alignment is transformed into a
2498 -- direct reference to the Alignment of the class type, so that the
2499 -- back end does not have to deal with the X'Class'Alignment
2502 if Is_Entity_Name (Pref)
2503 and then Is_Class_Wide_Type (Entity (Pref))
2505 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2508 -- For x'Alignment applied to an object of a class wide type,
2509 -- transform X'Alignment into a call to the predefined primitive
2510 -- operation _Alignment applied to X.
2512 elsif Is_Class_Wide_Type (Ptyp) then
2514 Make_Attribute_Reference (Loc,
2516 Attribute_Name => Name_Tag);
2518 New_Node := Build_Get_Alignment (Loc, New_Node);
2520 -- Case where the context is a specific integer type with which
2521 -- the original attribute was compatible. The function has a
2522 -- specific type as well, so to preserve the compatibility we
2523 -- must convert explicitly.
2525 if Typ /= Standard_Integer then
2526 New_Node := Convert_To (Typ, New_Node);
2529 Rewrite (N, New_Node);
2530 Analyze_And_Resolve (N, Typ);
2533 -- For all other cases, we just have to deal with the case of
2534 -- the fact that the result can be universal.
2537 Apply_Universal_Integer_Attribute_Checks (N);
2545 -- We compute this if a packed array reference was present, otherwise we
2546 -- leave the computation up to the back end.
2548 when Attribute_Bit =>
2549 if Involves_Packed_Array_Reference (Pref) then
2550 Expand_Packed_Bit_Reference (N);
2552 Apply_Universal_Integer_Attribute_Checks (N);
2559 -- We compute this if a component clause was present, otherwise we leave
2560 -- the computation up to the back end, since we don't know what layout
2563 -- Note that the attribute can apply to a naked record component
2564 -- in generated code (i.e. the prefix is an identifier that
2565 -- references the component or discriminant entity).
2567 when Attribute_Bit_Position => Bit_Position : declare
2571 if Nkind (Pref) = N_Identifier then
2572 CE := Entity (Pref);
2574 CE := Entity (Selector_Name (Pref));
2577 if Known_Static_Component_Bit_Offset (CE) then
2579 Make_Integer_Literal (Loc,
2580 Intval => Component_Bit_Offset (CE)));
2581 Analyze_And_Resolve (N, Typ);
2584 Apply_Universal_Integer_Attribute_Checks (N);
2592 -- A reference to P'Body_Version or P'Version is expanded to
2595 -- pragma Import (C, Vnn, "uuuuT");
2597 -- Get_Version_String (Vnn)
2599 -- where uuuu is the unit name (dots replaced by double underscore)
2600 -- and T is B for the cases of Body_Version, or Version applied to a
2601 -- subprogram acting as its own spec, and S for Version applied to a
2602 -- subprogram spec or package. This sequence of code references the
2603 -- unsigned constant created in the main program by the binder.
2605 -- A special exception occurs for Standard, where the string returned
2606 -- is a copy of the library string in gnatvsn.ads.
2608 when Attribute_Body_Version
2612 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2617 -- If not library unit, get to containing library unit
2619 Pent := Entity (Pref);
2620 while Pent /= Standard_Standard
2621 and then Scope (Pent) /= Standard_Standard
2622 and then not Is_Child_Unit (Pent)
2624 Pent := Scope (Pent);
2627 -- Special case Standard and Standard.ASCII
2629 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2631 Make_String_Literal (Loc,
2632 Strval => Verbose_Library_Version));
2637 -- Build required string constant
2639 Get_Name_String (Get_Unit_Name (Pent));
2642 for J in 1 .. Name_Len - 2 loop
2643 if Name_Buffer (J) = '.' then
2644 Store_String_Chars ("__");
2646 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2650 -- Case of subprogram acting as its own spec, always use body
2652 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2653 and then Nkind (Parent (Declaration_Node (Pent))) =
2655 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2657 Store_String_Chars ("B");
2659 -- Case of no body present, always use spec
2661 elsif not Unit_Requires_Body (Pent) then
2662 Store_String_Chars ("S");
2664 -- Otherwise use B for Body_Version, S for spec
2666 elsif Id = Attribute_Body_Version then
2667 Store_String_Chars ("B");
2669 Store_String_Chars ("S");
2673 Lib.Version_Referenced (S);
2675 -- Insert the object declaration
2677 Insert_Actions (N, New_List (
2678 Make_Object_Declaration (Loc,
2679 Defining_Identifier => E,
2680 Object_Definition =>
2681 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2683 -- Set entity as imported with correct external name
2685 Set_Is_Imported (E);
2686 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2688 -- Set entity as internal to ensure proper Sprint output of its
2689 -- implicit importation.
2691 Set_Is_Internal (E);
2693 -- And now rewrite original reference
2696 Make_Function_Call (Loc,
2698 New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2699 Parameter_Associations => New_List (
2700 New_Occurrence_Of (E, Loc))));
2703 Analyze_And_Resolve (N, RTE (RE_Version_String));
2710 -- Transforms 'Ceiling into a call to the floating-point attribute
2711 -- function Ceiling in Fat_xxx (where xxx is the root type)
2713 when Attribute_Ceiling =>
2714 Expand_Fpt_Attribute_R (N);
2720 -- Transforms 'Callable attribute into a call to the Callable function
2722 when Attribute_Callable =>
2724 -- We have an object of a task interface class-wide type as a prefix
2725 -- to Callable. Generate:
2726 -- callable (Task_Id (Pref._disp_get_task_id));
2728 if Ada_Version >= Ada_2005
2729 and then Ekind (Ptyp) = E_Class_Wide_Type
2730 and then Is_Interface (Ptyp)
2731 and then Is_Task_Interface (Ptyp)
2734 Make_Function_Call (Loc,
2736 New_Occurrence_Of (RTE (RE_Callable), Loc),
2737 Parameter_Associations => New_List (
2738 Make_Unchecked_Type_Conversion (Loc,
2740 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2741 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
2744 Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable)));
2747 Analyze_And_Resolve (N, Standard_Boolean);
2753 -- Transforms 'Caller attribute into a call to either the
2754 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2756 when Attribute_Caller => Caller : declare
2757 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2758 Ent : constant Entity_Id := Entity (Pref);
2759 Conctype : constant Entity_Id := Scope (Ent);
2760 Nest_Depth : Integer := 0;
2767 if Is_Protected_Type (Conctype) then
2768 case Corresponding_Runtime_Package (Conctype) is
2769 when System_Tasking_Protected_Objects_Entries =>
2772 (RTE (RE_Protected_Entry_Caller), Loc);
2774 when System_Tasking_Protected_Objects_Single_Entry =>
2777 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2780 raise Program_Error;
2784 Unchecked_Convert_To (Id_Kind,
2785 Make_Function_Call (Loc,
2787 Parameter_Associations => New_List (
2789 (Find_Protection_Object (Current_Scope), Loc)))));
2794 -- Determine the nesting depth of the E'Caller attribute, that
2795 -- is, how many accept statements are nested within the accept
2796 -- statement for E at the point of E'Caller. The runtime uses
2797 -- this depth to find the specified entry call.
2799 for J in reverse 0 .. Scope_Stack.Last loop
2800 S := Scope_Stack.Table (J).Entity;
2802 -- We should not reach the scope of the entry, as it should
2803 -- already have been checked in Sem_Attr that this attribute
2804 -- reference is within a matching accept statement.
2806 pragma Assert (S /= Conctype);
2811 elsif Is_Entry (S) then
2812 Nest_Depth := Nest_Depth + 1;
2817 Unchecked_Convert_To (Id_Kind,
2818 Make_Function_Call (Loc,
2820 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2821 Parameter_Associations => New_List (
2822 Make_Integer_Literal (Loc,
2823 Intval => Int (Nest_Depth))))));
2826 Analyze_And_Resolve (N, Id_Kind);
2833 -- Transforms 'Compose into a call to the floating-point attribute
2834 -- function Compose in Fat_xxx (where xxx is the root type)
2836 -- Note: we strictly should have special code here to deal with the
2837 -- case of absurdly negative arguments (less than Integer'First)
2838 -- which will return a (signed) zero value, but it hardly seems
2839 -- worth the effort. Absurdly large positive arguments will raise
2840 -- constraint error which is fine.
2842 when Attribute_Compose =>
2843 Expand_Fpt_Attribute_RI (N);
2849 when Attribute_Constrained => Constrained : declare
2850 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2852 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2853 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2854 -- view of an aliased object whose subtype is constrained.
2856 ---------------------------------
2857 -- Is_Constrained_Aliased_View --
2858 ---------------------------------
2860 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2864 if Is_Entity_Name (Obj) then
2867 if Present (Renamed_Object (E)) then
2868 return Is_Constrained_Aliased_View (Renamed_Object (E));
2870 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2874 return Is_Aliased_View (Obj)
2876 (Is_Constrained (Etype (Obj))
2878 (Nkind (Obj) = N_Explicit_Dereference
2880 not Object_Type_Has_Constrained_Partial_View
2881 (Typ => Base_Type (Etype (Obj)),
2882 Scop => Current_Scope)));
2884 end Is_Constrained_Aliased_View;
2886 -- Start of processing for Constrained
2889 -- Reference to a parameter where the value is passed as an extra
2890 -- actual, corresponding to the extra formal referenced by the
2891 -- Extra_Constrained field of the corresponding formal. If this
2892 -- is an entry in-parameter, it is replaced by a constant renaming
2893 -- for which Extra_Constrained is never created.
2895 if Present (Formal_Ent)
2896 and then Ekind (Formal_Ent) /= E_Constant
2897 and then Present (Extra_Constrained (Formal_Ent))
2901 (Extra_Constrained (Formal_Ent), Sloc (N)));
2903 -- If the prefix is an access to object, the attribute applies to
2904 -- the designated object, so rewrite with an explicit dereference.
2906 elsif Is_Access_Type (Etype (Pref))
2908 (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
2911 Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
2912 Analyze_And_Resolve (N, Standard_Boolean);
2915 -- For variables with a Extra_Constrained field, we use the
2916 -- corresponding entity.
2918 elsif Nkind (Pref) = N_Identifier
2919 and then Ekind (Entity (Pref)) = E_Variable
2920 and then Present (Extra_Constrained (Entity (Pref)))
2924 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2926 -- For all other entity names, we can tell at compile time
2928 elsif Is_Entity_Name (Pref) then
2930 Ent : constant Entity_Id := Entity (Pref);
2934 -- (RM J.4) obsolescent cases
2936 if Is_Type (Ent) then
2940 if Is_Private_Type (Ent) then
2941 Res := not Has_Discriminants (Ent)
2942 or else Is_Constrained (Ent);
2944 -- It not a private type, must be a generic actual type
2945 -- that corresponded to a private type. We know that this
2946 -- correspondence holds, since otherwise the reference
2947 -- within the generic template would have been illegal.
2950 if Is_Composite_Type (Underlying_Type (Ent)) then
2951 Res := Is_Constrained (Ent);
2958 -- For access type, apply access check as needed
2960 if Is_Access_Type (Ptyp) then
2961 Apply_Access_Check (N);
2964 -- If the prefix is not a variable or is aliased, then
2965 -- definitely true; if it's a formal parameter without an
2966 -- associated extra formal, then treat it as constrained.
2968 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2969 -- constrained in order to set the attribute to True.
2971 if not Is_Variable (Pref)
2972 or else Present (Formal_Ent)
2973 or else (Ada_Version < Ada_2005
2974 and then Is_Aliased_View (Pref))
2975 or else (Ada_Version >= Ada_2005
2976 and then Is_Constrained_Aliased_View (Pref))
2980 -- Variable case, look at type to see if it is constrained.
2981 -- Note that the one case where this is not accurate (the
2982 -- procedure formal case), has been handled above.
2984 -- We use the Underlying_Type here (and below) in case the
2985 -- type is private without discriminants, but the full type
2986 -- has discriminants. This case is illegal, but we generate
2987 -- it internally for passing to the Extra_Constrained
2991 -- In Ada 2012, test for case of a limited tagged type,
2992 -- in which case the attribute is always required to
2993 -- return True. The underlying type is tested, to make
2994 -- sure we also return True for cases where there is an
2995 -- unconstrained object with an untagged limited partial
2996 -- view which has defaulted discriminants (such objects
2997 -- always produce a False in earlier versions of
2998 -- Ada). (Ada 2012: AI05-0214)
3001 Is_Constrained (Underlying_Type (Etype (Ent)))
3003 (Ada_Version >= Ada_2012
3004 and then Is_Tagged_Type (Underlying_Type (Ptyp))
3005 and then Is_Limited_Type (Ptyp));
3009 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
3012 -- Prefix is not an entity name. These are also cases where we can
3013 -- always tell at compile time by looking at the form and type of the
3014 -- prefix. If an explicit dereference of an object with constrained
3015 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
3016 -- underlying type is a limited tagged type, then Constrained is
3017 -- required to always return True (Ada 2012: AI05-0214).
3023 not Is_Variable (Pref)
3025 (Nkind (Pref) = N_Explicit_Dereference
3027 not Object_Type_Has_Constrained_Partial_View
3028 (Typ => Base_Type (Ptyp),
3029 Scop => Current_Scope))
3030 or else Is_Constrained (Underlying_Type (Ptyp))
3031 or else (Ada_Version >= Ada_2012
3032 and then Is_Tagged_Type (Underlying_Type (Ptyp))
3033 and then Is_Limited_Type (Ptyp))),
3037 Analyze_And_Resolve (N, Standard_Boolean);
3044 -- Transforms 'Copy_Sign into a call to the floating-point attribute
3045 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
3047 when Attribute_Copy_Sign =>
3048 Expand_Fpt_Attribute_RR (N);
3054 -- Transforms 'Count attribute into a call to the Count function
3056 when Attribute_Count => Count : declare
3058 Conctyp : Entity_Id;
3060 Entry_Id : Entity_Id;
3065 -- If the prefix is a member of an entry family, retrieve both
3066 -- entry name and index. For a simple entry there is no index.
3068 if Nkind (Pref) = N_Indexed_Component then
3069 Entnam := Prefix (Pref);
3070 Index := First (Expressions (Pref));
3076 Entry_Id := Entity (Entnam);
3078 -- Find the concurrent type in which this attribute is referenced
3079 -- (there had better be one).
3081 Conctyp := Current_Scope;
3082 while not Is_Concurrent_Type (Conctyp) loop
3083 Conctyp := Scope (Conctyp);
3088 if Is_Protected_Type (Conctyp) then
3090 -- No need to transform 'Count into a function call if the current
3091 -- scope has been eliminated. In this case such transformation is
3092 -- also not viable because the enclosing protected object is not
3095 if Is_Eliminated (Current_Scope) then
3099 case Corresponding_Runtime_Package (Conctyp) is
3100 when System_Tasking_Protected_Objects_Entries =>
3101 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
3104 Make_Function_Call (Loc,
3106 Parameter_Associations => New_List (
3108 (Find_Protection_Object (Current_Scope), Loc),
3109 Entry_Index_Expression
3110 (Loc, Entry_Id, Index, Scope (Entry_Id))));
3112 when System_Tasking_Protected_Objects_Single_Entry =>
3114 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
3117 Make_Function_Call (Loc,
3119 Parameter_Associations => New_List (
3121 (Find_Protection_Object (Current_Scope), Loc)));
3124 raise Program_Error;
3131 Make_Function_Call (Loc,
3132 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
3133 Parameter_Associations => New_List (
3134 Entry_Index_Expression (Loc,
3135 Entry_Id, Index, Scope (Entry_Id))));
3138 -- The call returns type Natural but the context is universal integer
3139 -- so any integer type is allowed. The attribute was already resolved
3140 -- so its Etype is the required result type. If the base type of the
3141 -- context type is other than Standard.Integer we put in a conversion
3142 -- to the required type. This can be a normal typed conversion since
3143 -- both input and output types of the conversion are integer types
3145 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
3146 Rewrite (N, Convert_To (Typ, Call));
3151 Analyze_And_Resolve (N, Typ);
3154 ---------------------
3155 -- Descriptor_Size --
3156 ---------------------
3158 when Attribute_Descriptor_Size =>
3160 -- Attribute Descriptor_Size is handled by the back end when applied
3161 -- to an unconstrained array type.
3163 if Is_Array_Type (Ptyp)
3164 and then not Is_Constrained (Ptyp)
3166 Apply_Universal_Integer_Attribute_Checks (N);
3168 -- For any other type, the descriptor size is 0 because there is no
3169 -- actual descriptor, but the result is not formally static.
3172 Rewrite (N, Make_Integer_Literal (Loc, 0));
3174 Set_Is_Static_Expression (N, False);
3181 -- This processing is shared by Elab_Spec
3183 -- What we do is to insert the following declarations
3186 -- pragma Import (C, enn, "name___elabb/s");
3188 -- and then the Elab_Body/Spec attribute is replaced by a reference
3189 -- to this defining identifier.
3191 when Attribute_Elab_Body
3192 | Attribute_Elab_Spec
3194 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3195 -- back-end knows how to handle these attributes directly.
3197 if CodePeer_Mode then
3202 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
3206 procedure Make_Elab_String (Nod : Node_Id);
3207 -- Given Nod, an identifier, or a selected component, put the
3208 -- image into the current string literal, with double underline
3209 -- between components.
3211 ----------------------
3212 -- Make_Elab_String --
3213 ----------------------
3215 procedure Make_Elab_String (Nod : Node_Id) is
3217 if Nkind (Nod) = N_Selected_Component then
3218 Make_Elab_String (Prefix (Nod));
3219 Store_String_Char ('_');
3220 Store_String_Char ('_');
3221 Get_Name_String (Chars (Selector_Name (Nod)));
3224 pragma Assert (Nkind (Nod) = N_Identifier);
3225 Get_Name_String (Chars (Nod));
3228 Store_String_Chars (Name_Buffer (1 .. Name_Len));
3229 end Make_Elab_String;
3231 -- Start of processing for Elab_Body/Elab_Spec
3234 -- First we need to prepare the string literal for the name of
3235 -- the elaboration routine to be referenced.
3238 Make_Elab_String (Pref);
3239 Store_String_Chars ("___elab");
3240 Lang := Make_Identifier (Loc, Name_C);
3242 if Id = Attribute_Elab_Body then
3243 Store_String_Char ('b');
3245 Store_String_Char ('s');
3250 Insert_Actions (N, New_List (
3251 Make_Subprogram_Declaration (Loc,
3253 Make_Procedure_Specification (Loc,
3254 Defining_Unit_Name => Ent)),
3257 Chars => Name_Import,
3258 Pragma_Argument_Associations => New_List (
3259 Make_Pragma_Argument_Association (Loc, Expression => Lang),
3261 Make_Pragma_Argument_Association (Loc,
3262 Expression => Make_Identifier (Loc, Chars (Ent))),
3264 Make_Pragma_Argument_Association (Loc,
3265 Expression => Make_String_Literal (Loc, Str))))));
3267 Set_Entity (N, Ent);
3268 Rewrite (N, New_Occurrence_Of (Ent, Loc));
3271 --------------------
3272 -- Elab_Subp_Body --
3273 --------------------
3275 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3276 -- this attribute directly, and if we are not in CodePeer mode it is
3277 -- entirely ignored ???
3279 when Attribute_Elab_Subp_Body =>
3286 -- Elaborated is always True for preelaborated units, predefined units,
3287 -- pure units and units which have Elaborate_Body pragmas. These units
3288 -- have no elaboration entity.
3290 -- Note: The Elaborated attribute is never passed to the back end
3292 when Attribute_Elaborated => Elaborated : declare
3293 Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
3296 if Present (Elab_Id) then
3299 Left_Opnd => New_Occurrence_Of (Elab_Id, Loc),
3300 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
3302 Analyze_And_Resolve (N, Typ);
3304 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3312 when Attribute_Enum_Rep => Enum_Rep : declare
3316 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3319 if Is_Non_Empty_List (Exprs) then
3320 Expr := First (Exprs);
3325 -- If the expression is an enumeration literal, it is replaced by the
3328 if Nkind (Expr) in N_Has_Entity
3329 and then Ekind (Entity (Expr)) = E_Enumeration_Literal
3332 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
3334 -- If this is a renaming of a literal, recover the representation
3335 -- of the original. If it renames an expression there is nothing to
3338 elsif Nkind (Expr) in N_Has_Entity
3339 and then Ekind (Entity (Expr)) = E_Constant
3340 and then Present (Renamed_Object (Entity (Expr)))
3341 and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
3342 and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
3343 E_Enumeration_Literal
3346 Make_Integer_Literal (Loc,
3347 Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
3349 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3350 -- X'Enum_Rep expands to
3354 -- This is simply a direct conversion from the enumeration type to
3355 -- the target integer type, which is treated by the back end as a
3356 -- normal integer conversion, treating the enumeration type as an
3357 -- integer, which is exactly what we want. We set Conversion_OK to
3358 -- make sure that the analyzer does not complain about what otherwise
3359 -- might be an illegal conversion.
3362 Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
3366 Analyze_And_Resolve (N, Typ);
3373 when Attribute_Enum_Val => Enum_Val : declare
3375 Btyp : constant Entity_Id := Base_Type (Ptyp);
3378 -- X'Enum_Val (Y) expands to
3380 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3383 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3386 Make_Raise_Constraint_Error (Loc,
3390 Make_Function_Call (Loc,
3392 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3393 Parameter_Associations => New_List (
3394 Relocate_Node (Duplicate_Subexpr (Expr)),
3395 New_Occurrence_Of (Standard_False, Loc))),
3397 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3398 Reason => CE_Range_Check_Failed));
3401 Analyze_And_Resolve (N, Ptyp);
3408 -- Transforms 'Exponent into a call to the floating-point attribute
3409 -- function Exponent in Fat_xxx (where xxx is the root type)
3411 when Attribute_Exponent =>
3412 Expand_Fpt_Attribute_R (N);
3418 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3420 when Attribute_External_Tag =>
3422 Make_Function_Call (Loc,
3424 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3425 Parameter_Associations => New_List (
3426 Make_Attribute_Reference (Loc,
3427 Attribute_Name => Name_Tag,
3428 Prefix => Prefix (N)))));
3430 Analyze_And_Resolve (N, Standard_String);
3432 -----------------------
3433 -- Finalization_Size --
3434 -----------------------
3436 when Attribute_Finalization_Size => Finalization_Size : declare
3437 function Calculate_Header_Size return Node_Id;
3438 -- Generate a runtime call to calculate the size of the hidden header
3439 -- along with any added padding which would precede a heap-allocated
3440 -- object of the prefix type.
3442 ---------------------------
3443 -- Calculate_Header_Size --
3444 ---------------------------
3446 function Calculate_Header_Size return Node_Id is
3449 -- Universal_Integer
3450 -- (Header_Size_With_Padding (Pref'Alignment))
3453 Convert_To (Universal_Integer,
3454 Make_Function_Call (Loc,
3456 New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
3458 Parameter_Associations => New_List (
3459 Make_Attribute_Reference (Loc,
3460 Prefix => New_Copy_Tree (Pref),
3461 Attribute_Name => Name_Alignment))));
3462 end Calculate_Header_Size;
3468 -- Start of Finalization_Size
3471 -- An object of a class-wide type first requires a runtime check to
3472 -- determine whether it is actually controlled or not. Depending on
3473 -- the outcome of this check, the Finalization_Size of the object
3474 -- may be zero or some positive value.
3476 -- In this scenario, Pref'Finalization_Size is expanded into
3478 -- Size : Integer := 0;
3480 -- if Needs_Finalization (Pref'Tag) then
3482 -- Universal_Integer
3483 -- (Header_Size_With_Padding (Pref'Alignment));
3486 -- and the attribute reference is replaced with a reference to Size.
3488 if Is_Class_Wide_Type (Ptyp) then
3489 Size := Make_Temporary (Loc, 'S');
3491 Insert_Actions (N, New_List (
3494 -- Size : Integer := 0;
3496 Make_Object_Declaration (Loc,
3497 Defining_Identifier => Size,
3498 Object_Definition =>
3499 New_Occurrence_Of (Standard_Integer, Loc),
3500 Expression => Make_Integer_Literal (Loc, 0)),
3503 -- if Needs_Finalization (Pref'Tag) then
3505 -- Universal_Integer
3506 -- (Header_Size_With_Padding (Pref'Alignment));
3509 Make_If_Statement (Loc,
3511 Make_Function_Call (Loc,
3513 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
3515 Parameter_Associations => New_List (
3516 Make_Attribute_Reference (Loc,
3517 Prefix => New_Copy_Tree (Pref),
3518 Attribute_Name => Name_Tag))),
3520 Then_Statements => New_List (
3521 Make_Assignment_Statement (Loc,
3522 Name => New_Occurrence_Of (Size, Loc),
3523 Expression => Calculate_Header_Size)))));
3525 Rewrite (N, New_Occurrence_Of (Size, Loc));
3527 -- The prefix is known to be controlled at compile time. Calculate
3528 -- Finalization_Size by calling function Header_Size_With_Padding.
3530 elsif Needs_Finalization (Ptyp) then
3531 Rewrite (N, Calculate_Header_Size);
3533 -- The prefix is not an object with controlled parts, so its
3534 -- Finalization_Size is zero.
3537 Rewrite (N, Make_Integer_Literal (Loc, 0));
3540 -- Due to cases where the entity type of the attribute is already
3541 -- resolved the rewritten N must get re-resolved to its appropriate
3544 Analyze_And_Resolve (N, Typ);
3545 end Finalization_Size;
3551 when Attribute_First =>
3553 -- If the prefix type is a constrained packed array type which
3554 -- already has a Packed_Array_Impl_Type representation defined, then
3555 -- replace this attribute with a direct reference to 'First of the
3556 -- appropriate index subtype (since otherwise the back end will try
3557 -- to give us the value of 'First for this implementation type).
3559 if Is_Constrained_Packed_Array (Ptyp) then
3561 Make_Attribute_Reference (Loc,
3562 Attribute_Name => Name_First,
3564 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3565 Analyze_And_Resolve (N, Typ);
3567 -- For access type, apply access check as needed
3569 elsif Is_Access_Type (Ptyp) then
3570 Apply_Access_Check (N);
3572 -- For scalar type, if low bound is a reference to an entity, just
3573 -- replace with a direct reference. Note that we can only have a
3574 -- reference to a constant entity at this stage, anything else would
3575 -- have already been rewritten.
3577 elsif Is_Scalar_Type (Ptyp) then
3579 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3581 if Is_Entity_Name (Lo) then
3582 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3591 -- Compute this if component clause was present, otherwise we leave the
3592 -- computation to be completed in the back-end, since we don't know what
3593 -- layout will be chosen.
3595 when Attribute_First_Bit => First_Bit_Attr : declare
3596 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3599 -- In Ada 2005 (or later) if we have the non-default bit order, then
3600 -- we return the original value as given in the component clause
3601 -- (RM 2005 13.5.2(3/2)).
3603 if Present (Component_Clause (CE))
3604 and then Ada_Version >= Ada_2005
3605 and then Reverse_Bit_Order (Scope (CE))
3608 Make_Integer_Literal (Loc,
3609 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3610 Analyze_And_Resolve (N, Typ);
3612 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3613 -- rewrite with normalized value if we know it statically.
3615 elsif Known_Static_Component_Bit_Offset (CE) then
3617 Make_Integer_Literal (Loc,
3618 Component_Bit_Offset (CE) mod System_Storage_Unit));
3619 Analyze_And_Resolve (N, Typ);
3621 -- Otherwise left to back end, just do universal integer checks
3624 Apply_Universal_Integer_Attribute_Checks (N);
3628 --------------------------------
3629 -- Fixed_Value, Integer_Value --
3630 --------------------------------
3634 -- fixtype'Fixed_Value (integer-value)
3635 -- inttype'Fixed_Value (fixed-value)
3639 -- fixtype (integer-value)
3640 -- inttype (fixed-value)
3644 -- We do all the required analysis of the conversion here, because we do
3645 -- not want this to go through the fixed-point conversion circuits. Note
3646 -- that the back end always treats fixed-point as equivalent to the
3647 -- corresponding integer type anyway.
3648 -- However, in order to remove the handling of Do_Range_Check from the
3649 -- backend, we force the generation of a check on the result by
3650 -- setting the result type appropriately. Apply_Conversion_Checks
3651 -- will generate the required expansion.
3653 when Attribute_Fixed_Value
3654 | Attribute_Integer_Value
3657 Make_Type_Conversion (Loc,
3658 Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
3659 Expression => Relocate_Node (First (Exprs))));
3661 -- Indicate that the result of the conversion may require a
3662 -- range check (see below);
3664 Set_Etype (N, Base_Type (Entity (Pref)));
3667 -- Note: it might appear that a properly analyzed unchecked
3668 -- conversion would be just fine here, but that's not the case,
3669 -- since the full range checks performed by the following code
3671 -- Given that Fixed-point conversions are not further expanded
3672 -- to prevent the involvement of real type operations we have to
3673 -- construct two checks explicitly: one on the operand, and one
3674 -- on the result. This used to be done in part in the back-end,
3675 -- but for other targets (E.g. LLVM) it is preferable to create
3676 -- the tests in full in the front-end.
3678 if Is_Fixed_Point_Type (Etype (N)) then
3680 Loc : constant Source_Ptr := Sloc (N);
3681 Equiv_T : constant Entity_Id := Make_Temporary (Loc, 'T', N);
3682 Expr : constant Node_Id := Expression (N);
3683 Fst : constant Entity_Id := Root_Type (Etype (N));
3688 Make_Full_Type_Declaration (Sloc (N),
3689 Defining_Identifier => Equiv_T,
3691 Make_Signed_Integer_Type_Definition (Loc,
3693 Make_Integer_Literal (Loc,
3695 Corresponding_Integer_Value
3696 (Type_Low_Bound (Fst))),
3698 Make_Integer_Literal (Loc,
3700 Corresponding_Integer_Value
3701 (Type_High_Bound (Fst)))));
3702 Insert_Action (N, Decl);
3704 -- Verify that the conversion is possible
3706 Generate_Range_Check (Expr, Equiv_T, CE_Overflow_Check_Failed);
3708 -- and verify that the result is in range
3710 Generate_Range_Check (N, Etype (N), CE_Range_Check_Failed);
3718 -- Transforms 'Floor into a call to the floating-point attribute
3719 -- function Floor in Fat_xxx (where xxx is the root type)
3721 when Attribute_Floor =>
3722 Expand_Fpt_Attribute_R (N);
3728 -- For the fixed-point type Typ:
3734 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3735 -- Universal_Real (Type'Last))
3737 -- Note that we know that the type is a non-static subtype, or Fore
3738 -- would have itself been computed dynamically in Eval_Attribute.
3740 when Attribute_Fore =>
3743 Make_Function_Call (Loc,
3745 New_Occurrence_Of (RTE (RE_Fore), Loc),
3747 Parameter_Associations => New_List (
3748 Convert_To (Universal_Real,
3749 Make_Attribute_Reference (Loc,
3750 Prefix => New_Occurrence_Of (Ptyp, Loc),
3751 Attribute_Name => Name_First)),
3753 Convert_To (Universal_Real,
3754 Make_Attribute_Reference (Loc,
3755 Prefix => New_Occurrence_Of (Ptyp, Loc),
3756 Attribute_Name => Name_Last))))));
3758 Analyze_And_Resolve (N, Typ);
3764 -- Transforms 'Fraction into a call to the floating-point attribute
3765 -- function Fraction in Fat_xxx (where xxx is the root type)
3767 when Attribute_Fraction =>
3768 Expand_Fpt_Attribute_R (N);
3774 when Attribute_From_Any => From_Any : declare
3775 P_Type : constant Entity_Id := Etype (Pref);
3776 Decls : constant List_Id := New_List;
3780 Build_From_Any_Call (P_Type,
3781 Relocate_Node (First (Exprs)),
3783 Insert_Actions (N, Decls);
3784 Analyze_And_Resolve (N, P_Type);
3787 ----------------------
3788 -- Has_Same_Storage --
3789 ----------------------
3791 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3792 Loc : constant Source_Ptr := Sloc (N);
3794 X : constant Node_Id := Prefix (N);
3795 Y : constant Node_Id := First (Expressions (N));
3800 -- Rhe expressions for their addresses
3804 -- Rhe expressions for their sizes
3807 -- The attribute is expanded as:
3809 -- (X'address = Y'address)
3810 -- and then (X'Size = Y'Size)
3812 -- If both arguments have the same Etype the second conjunct can be
3816 Make_Attribute_Reference (Loc,
3817 Attribute_Name => Name_Address,
3818 Prefix => New_Copy_Tree (X));
3821 Make_Attribute_Reference (Loc,
3822 Attribute_Name => Name_Address,
3823 Prefix => New_Copy_Tree (Y));
3826 Make_Attribute_Reference (Loc,
3827 Attribute_Name => Name_Size,
3828 Prefix => New_Copy_Tree (X));
3831 Make_Attribute_Reference (Loc,
3832 Attribute_Name => Name_Size,
3833 Prefix => New_Copy_Tree (Y));
3835 if Etype (X) = Etype (Y) then
3838 Left_Opnd => X_Addr,
3839 Right_Opnd => Y_Addr));
3845 Left_Opnd => X_Addr,
3846 Right_Opnd => Y_Addr),
3849 Left_Opnd => X_Size,
3850 Right_Opnd => Y_Size)));
3853 Analyze_And_Resolve (N, Standard_Boolean);
3854 end Has_Same_Storage;
3860 -- For an exception returns a reference to the exception data:
3861 -- Exception_Id!(Prefix'Reference)
3863 -- For a task it returns a reference to the _task_id component of
3864 -- corresponding record:
3866 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3868 -- in Ada.Task_Identification
3870 when Attribute_Identity => Identity : declare
3871 Id_Kind : Entity_Id;
3874 if Ptyp = Standard_Exception_Type then
3875 Id_Kind := RTE (RE_Exception_Id);
3877 if Present (Renamed_Object (Entity (Pref))) then
3878 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3882 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3884 Id_Kind := RTE (RO_AT_Task_Id);
3886 -- If the prefix is a task interface, the Task_Id is obtained
3887 -- dynamically through a dispatching call, as for other task
3888 -- attributes applied to interfaces.
3890 if Ada_Version >= Ada_2005
3891 and then Ekind (Ptyp) = E_Class_Wide_Type
3892 and then Is_Interface (Ptyp)
3893 and then Is_Task_Interface (Ptyp)
3896 Unchecked_Convert_To
3897 (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref)));
3901 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3905 Analyze_And_Resolve (N, Id_Kind);
3912 -- Image attribute is handled in separate unit Exp_Imgv
3914 when Attribute_Image =>
3916 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3917 -- back-end knows how to handle this attribute directly.
3919 if CodePeer_Mode then
3923 Expand_Image_Attribute (N);
3929 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3931 when Attribute_Img =>
3932 Expand_Image_Attribute (N);
3938 when Attribute_Input => Input : declare
3939 P_Type : constant Entity_Id := Entity (Pref);
3940 B_Type : constant Entity_Id := Base_Type (P_Type);
3941 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3942 Strm : constant Node_Id := First (Exprs);
3950 Cntrl : Node_Id := Empty;
3951 -- Value for controlling argument in call. Always Empty except in
3952 -- the dispatching (class-wide type) case, where it is a reference
3953 -- to the dummy object initialized to the right internal tag.
3955 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3956 -- The expansion of the attribute reference may generate a call to
3957 -- a user-defined stream subprogram that is frozen by the call. This
3958 -- can lead to access-before-elaboration problem if the reference
3959 -- appears in an object declaration and the subprogram body has not
3960 -- been seen. The freezing of the subprogram requires special code
3961 -- because it appears in an expanded context where expressions do
3962 -- not freeze their constituents.
3964 ------------------------------
3965 -- Freeze_Stream_Subprogram --
3966 ------------------------------
3968 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3969 Decl : constant Node_Id := Unit_Declaration_Node (F);
3973 -- If this is user-defined subprogram, the corresponding
3974 -- stream function appears as a renaming-as-body, and the
3975 -- user subprogram must be retrieved by tree traversal.
3978 and then Nkind (Decl) = N_Subprogram_Declaration
3979 and then Present (Corresponding_Body (Decl))
3981 Bod := Corresponding_Body (Decl);
3983 if Nkind (Unit_Declaration_Node (Bod)) =
3984 N_Subprogram_Renaming_Declaration
3986 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3989 end Freeze_Stream_Subprogram;
3991 -- Start of processing for Input
3994 -- If no underlying type, we have an error that will be diagnosed
3995 -- elsewhere, so here we just completely ignore the expansion.
4001 -- Stream operations can appear in user code even if the restriction
4002 -- No_Streams is active (for example, when instantiating a predefined
4003 -- container). In that case rewrite the attribute as a Raise to
4004 -- prevent any run-time use.
4006 if Restriction_Active (No_Streams) then
4008 Make_Raise_Program_Error (Sloc (N),
4009 Reason => PE_Stream_Operation_Not_Allowed));
4010 Set_Etype (N, B_Type);
4014 -- If there is a TSS for Input, just call it
4016 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
4018 if Present (Fname) then
4022 -- If there is a Stream_Convert pragma, use it, we rewrite
4024 -- sourcetyp'Input (stream)
4028 -- sourcetyp (streamread (strmtyp'Input (stream)));
4030 -- where streamread is the given Read function that converts an
4031 -- argument of type strmtyp to type sourcetyp or a type from which
4032 -- it is derived (extra conversion required for the derived case).
4034 Prag := Get_Stream_Convert_Pragma (P_Type);
4036 if Present (Prag) then
4037 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
4038 Rfunc := Entity (Expression (Arg2));
4042 Make_Function_Call (Loc,
4043 Name => New_Occurrence_Of (Rfunc, Loc),
4044 Parameter_Associations => New_List (
4045 Make_Attribute_Reference (Loc,
4048 (Etype (First_Formal (Rfunc)), Loc),
4049 Attribute_Name => Name_Input,
4050 Expressions => Exprs)))));
4052 Analyze_And_Resolve (N, B_Type);
4057 elsif Is_Elementary_Type (U_Type) then
4059 -- A special case arises if we have a defined _Read routine,
4060 -- since in this case we are required to call this routine.
4063 Typ : Entity_Id := P_Type;
4065 if Present (Full_View (Typ)) then
4066 Typ := Full_View (Typ);
4069 if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
4070 Build_Record_Or_Elementary_Input_Function
4071 (Loc, Typ, Decl, Fname, Use_Underlying => False);
4072 Insert_Action (N, Decl);
4074 -- For normal cases, we call the I_xxx routine directly
4077 Rewrite (N, Build_Elementary_Input_Call (N));
4078 Analyze_And_Resolve (N, P_Type);
4085 elsif Is_Array_Type (U_Type) then
4086 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
4087 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
4089 -- Dispatching case with class-wide type
4091 elsif Is_Class_Wide_Type (P_Type) then
4093 -- No need to do anything else compiling under restriction
4094 -- No_Dispatching_Calls. During the semantic analysis we
4095 -- already notified such violation.
4097 if Restriction_Active (No_Dispatching_Calls) then
4102 Rtyp : constant Entity_Id := Root_Type (P_Type);
4106 -- Read the internal tag (RM 13.13.2(34)) and use it to
4107 -- initialize a dummy tag value. We used to generate:
4109 -- Descendant_Tag (String'Input (Strm), P_Type);
4111 -- which turns into a call to String_Input_Blk_IO. However,
4112 -- if the input is malformed, that could try to read an
4113 -- enormous String, causing chaos. So instead we call
4114 -- String_Input_Tag, which does the same thing as
4115 -- String_Input_Blk_IO, except that if the String is
4116 -- absurdly long, it raises an exception.
4118 -- This value is used only to provide a controlling
4119 -- argument for the eventual _Input call. Descendant_Tag is
4120 -- called rather than Internal_Tag to ensure that we have a
4121 -- tag for a type that is descended from the prefix type and
4122 -- declared at the same accessibility level (the exception
4123 -- Tag_Error will be raised otherwise). The level check is
4124 -- required for Ada 2005 because tagged types can be
4125 -- extended in nested scopes (AI-344).
4127 -- Note: we used to generate an explicit declaration of a
4128 -- constant Ada.Tags.Tag object, and use an occurrence of
4129 -- this constant in Cntrl, but this caused a secondary stack
4133 Make_Function_Call (Loc,
4135 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
4136 Parameter_Associations => New_List (
4137 Make_Function_Call (Loc,
4140 (RTE (RE_String_Input_Tag), Loc),
4141 Parameter_Associations => New_List (
4142 Relocate_Node (Duplicate_Subexpr (Strm)))),
4144 Make_Attribute_Reference (Loc,
4145 Prefix => New_Occurrence_Of (P_Type, Loc),
4146 Attribute_Name => Name_Tag)));
4148 Set_Etype (Expr, RTE (RE_Tag));
4150 -- Now we need to get the entity for the call, and construct
4151 -- a function call node, where we preset a reference to Dnn
4152 -- as the controlling argument (doing an unchecked convert
4153 -- to the class-wide tagged type to make it look like a real
4156 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
4157 Cntrl := Unchecked_Convert_To (P_Type, Expr);
4158 Set_Etype (Cntrl, P_Type);
4159 Set_Parent (Cntrl, N);
4162 -- For tagged types, use the primitive Input function
4164 elsif Is_Tagged_Type (U_Type) then
4165 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
4167 -- All other record type cases, including protected records. The
4168 -- latter only arise for expander generated code for handling
4169 -- shared passive partition access.
4173 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4175 -- Ada 2005 (AI-216): Program_Error is raised executing default
4176 -- implementation of the Input attribute of an unchecked union
4177 -- type if the type lacks default discriminant values.
4179 if Is_Unchecked_Union (Base_Type (U_Type))
4180 and then No (Discriminant_Constraint (U_Type))
4183 Make_Raise_Program_Error (Loc,
4184 Reason => PE_Unchecked_Union_Restriction));
4189 -- Build the type's Input function, passing the subtype rather
4190 -- than its base type, because checks are needed in the case of
4191 -- constrained discriminants (see Ada 2012 AI05-0192).
4193 Build_Record_Or_Elementary_Input_Function
4194 (Loc, U_Type, Decl, Fname);
4195 Insert_Action (N, Decl);
4197 if Nkind (Parent (N)) = N_Object_Declaration
4198 and then Is_Record_Type (U_Type)
4200 -- The stream function may contain calls to user-defined
4201 -- Read procedures for individual components.
4208 Comp := First_Component (U_Type);
4209 while Present (Comp) loop
4211 Find_Stream_Subprogram
4212 (Etype (Comp), TSS_Stream_Read);
4214 if Present (Func) then
4215 Freeze_Stream_Subprogram (Func);
4218 Next_Component (Comp);
4225 -- If we fall through, Fname is the function to be called. The result
4226 -- is obtained by calling the appropriate function, then converting
4227 -- the result. The conversion does a subtype check.
4230 Make_Function_Call (Loc,
4231 Name => New_Occurrence_Of (Fname, Loc),
4232 Parameter_Associations => New_List (
4233 Relocate_Node (Strm)));
4235 Set_Controlling_Argument (Call, Cntrl);
4236 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
4237 Analyze_And_Resolve (N, P_Type);
4239 if Nkind (Parent (N)) = N_Object_Declaration then
4240 Freeze_Stream_Subprogram (Fname);
4248 when Attribute_Invalid_Value =>
4249 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
4251 -- The value produced may be a conversion of a literal, which must be
4252 -- resolved to establish its proper type.
4254 Analyze_And_Resolve (N);
4260 when Attribute_Last =>
4262 -- If the prefix type is a constrained packed array type which
4263 -- already has a Packed_Array_Impl_Type representation defined, then
4264 -- replace this attribute with a direct reference to 'Last of the
4265 -- appropriate index subtype (since otherwise the back end will try
4266 -- to give us the value of 'Last for this implementation type).
4268 if Is_Constrained_Packed_Array (Ptyp) then
4270 Make_Attribute_Reference (Loc,
4271 Attribute_Name => Name_Last,
4272 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
4273 Analyze_And_Resolve (N, Typ);
4275 -- For access type, apply access check as needed
4277 elsif Is_Access_Type (Ptyp) then
4278 Apply_Access_Check (N);
4280 -- For scalar type, if low bound is a reference to an entity, just
4281 -- replace with a direct reference. Note that we can only have a
4282 -- reference to a constant entity at this stage, anything else would
4283 -- have already been rewritten.
4285 elsif Is_Scalar_Type (Ptyp) then
4287 Hi : constant Node_Id := Type_High_Bound (Ptyp);
4289 if Is_Entity_Name (Hi) then
4290 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
4299 -- We compute this if a component clause was present, otherwise we leave
4300 -- the computation up to the back end, since we don't know what layout
4303 when Attribute_Last_Bit => Last_Bit_Attr : declare
4304 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4307 -- In Ada 2005 (or later) if we have the non-default bit order, then
4308 -- we return the original value as given in the component clause
4309 -- (RM 2005 13.5.2(3/2)).
4311 if Present (Component_Clause (CE))
4312 and then Ada_Version >= Ada_2005
4313 and then Reverse_Bit_Order (Scope (CE))
4316 Make_Integer_Literal (Loc,
4317 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
4318 Analyze_And_Resolve (N, Typ);
4320 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4321 -- rewrite with normalized value if we know it statically.
4323 elsif Known_Static_Component_Bit_Offset (CE)
4324 and then Known_Static_Esize (CE)
4327 Make_Integer_Literal (Loc,
4328 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
4330 Analyze_And_Resolve (N, Typ);
4332 -- Otherwise leave to back end, just apply universal integer checks
4335 Apply_Universal_Integer_Attribute_Checks (N);
4343 -- Transforms 'Leading_Part into a call to the floating-point attribute
4344 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4346 -- Note: strictly, we should generate special case code to deal with
4347 -- absurdly large positive arguments (greater than Integer'Last), which
4348 -- result in returning the first argument unchanged, but it hardly seems
4349 -- worth the effort. We raise constraint error for absurdly negative
4350 -- arguments which is fine.
4352 when Attribute_Leading_Part =>
4353 Expand_Fpt_Attribute_RI (N);
4359 when Attribute_Length => Length : declare
4364 -- Processing for packed array types
4366 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
4367 Ityp := Get_Index_Subtype (N);
4369 -- If the index type, Ityp, is an enumeration type with holes,
4370 -- then we calculate X'Length explicitly using
4373 -- (0, Ityp'Pos (X'Last (N)) -
4374 -- Ityp'Pos (X'First (N)) + 1);
4376 -- Since the bounds in the template are the representation values
4377 -- and the back end would get the wrong value.
4379 if Is_Enumeration_Type (Ityp)
4380 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
4385 Xnum := Expr_Value (First (Expressions (N)));
4389 Make_Attribute_Reference (Loc,
4390 Prefix => New_Occurrence_Of (Typ, Loc),
4391 Attribute_Name => Name_Max,
4392 Expressions => New_List
4393 (Make_Integer_Literal (Loc, 0),
4397 Make_Op_Subtract (Loc,
4399 Make_Attribute_Reference (Loc,
4400 Prefix => New_Occurrence_Of (Ityp, Loc),
4401 Attribute_Name => Name_Pos,
4403 Expressions => New_List (
4404 Make_Attribute_Reference (Loc,
4405 Prefix => Duplicate_Subexpr (Pref),
4406 Attribute_Name => Name_Last,
4407 Expressions => New_List (
4408 Make_Integer_Literal (Loc, Xnum))))),
4411 Make_Attribute_Reference (Loc,
4412 Prefix => New_Occurrence_Of (Ityp, Loc),
4413 Attribute_Name => Name_Pos,
4415 Expressions => New_List (
4416 Make_Attribute_Reference (Loc,
4418 Duplicate_Subexpr_No_Checks (Pref),
4419 Attribute_Name => Name_First,
4420 Expressions => New_List (
4421 Make_Integer_Literal (Loc, Xnum)))))),
4423 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4425 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
4428 -- If the prefix type is a constrained packed array type which
4429 -- already has a Packed_Array_Impl_Type representation defined,
4430 -- then replace this attribute with a reference to 'Range_Length
4431 -- of the appropriate index subtype (since otherwise the
4432 -- back end will try to give us the value of 'Length for
4433 -- this implementation type).s
4435 elsif Is_Constrained (Ptyp) then
4437 Make_Attribute_Reference (Loc,
4438 Attribute_Name => Name_Range_Length,
4439 Prefix => New_Occurrence_Of (Ityp, Loc)));
4440 Analyze_And_Resolve (N, Typ);
4445 elsif Is_Access_Type (Ptyp) then
4446 Apply_Access_Check (N);
4448 -- If the designated type is a packed array type, then we convert
4449 -- the reference to:
4452 -- xtyp'Pos (Pref'Last (Expr)) -
4453 -- xtyp'Pos (Pref'First (Expr)));
4455 -- This is a bit complex, but it is the easiest thing to do that
4456 -- works in all cases including enum types with holes xtyp here
4457 -- is the appropriate index type.
4460 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
4464 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4465 Xtyp := Get_Index_Subtype (N);
4468 Make_Attribute_Reference (Loc,
4469 Prefix => New_Occurrence_Of (Typ, Loc),
4470 Attribute_Name => Name_Max,
4471 Expressions => New_List (
4472 Make_Integer_Literal (Loc, 0),
4475 Make_Integer_Literal (Loc, 1),
4476 Make_Op_Subtract (Loc,
4478 Make_Attribute_Reference (Loc,
4479 Prefix => New_Occurrence_Of (Xtyp, Loc),
4480 Attribute_Name => Name_Pos,
4481 Expressions => New_List (
4482 Make_Attribute_Reference (Loc,
4483 Prefix => Duplicate_Subexpr (Pref),
4484 Attribute_Name => Name_Last,
4486 New_Copy_List (Exprs)))),
4489 Make_Attribute_Reference (Loc,
4490 Prefix => New_Occurrence_Of (Xtyp, Loc),
4491 Attribute_Name => Name_Pos,
4492 Expressions => New_List (
4493 Make_Attribute_Reference (Loc,
4495 Duplicate_Subexpr_No_Checks (Pref),
4496 Attribute_Name => Name_First,
4498 New_Copy_List (Exprs)))))))));
4500 Analyze_And_Resolve (N, Typ);
4504 -- Otherwise leave it to the back end
4507 Apply_Universal_Integer_Attribute_Checks (N);
4511 -- Attribute Loop_Entry is replaced with a reference to a constant value
4512 -- which captures the prefix at the entry point of the related loop. The
4513 -- loop itself may be transformed into a conditional block.
4515 when Attribute_Loop_Entry =>
4516 Expand_Loop_Entry_Attribute (N);
4522 -- Transforms 'Machine into a call to the floating-point attribute
4523 -- function Machine in Fat_xxx (where xxx is the root type).
4524 -- Expansion is avoided for cases the back end can handle directly.
4526 when Attribute_Machine =>
4527 if not Is_Inline_Floating_Point_Attribute (N) then
4528 Expand_Fpt_Attribute_R (N);
4531 ----------------------
4532 -- Machine_Rounding --
4533 ----------------------
4535 -- Transforms 'Machine_Rounding into a call to the floating-point
4536 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4537 -- type). Expansion is avoided for cases the back end can handle
4540 when Attribute_Machine_Rounding =>
4541 if not Is_Inline_Floating_Point_Attribute (N) then
4542 Expand_Fpt_Attribute_R (N);
4549 -- Machine_Size is equivalent to Object_Size, so transform it into
4550 -- Object_Size and that way the back end never sees Machine_Size.
4552 when Attribute_Machine_Size =>
4554 Make_Attribute_Reference (Loc,
4555 Prefix => Prefix (N),
4556 Attribute_Name => Name_Object_Size));
4558 Analyze_And_Resolve (N, Typ);
4564 -- The only case that can get this far is the dynamic case of the old
4565 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4572 -- ityp (System.Mantissa.Mantissa_Value
4573 -- (Integer'Integer_Value (typ'First),
4574 -- Integer'Integer_Value (typ'Last)));
4576 when Attribute_Mantissa =>
4579 Make_Function_Call (Loc,
4581 New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4583 Parameter_Associations => New_List (
4584 Make_Attribute_Reference (Loc,
4585 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4586 Attribute_Name => Name_Integer_Value,
4587 Expressions => New_List (
4588 Make_Attribute_Reference (Loc,
4589 Prefix => New_Occurrence_Of (Ptyp, Loc),
4590 Attribute_Name => Name_First))),
4592 Make_Attribute_Reference (Loc,
4593 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4594 Attribute_Name => Name_Integer_Value,
4595 Expressions => New_List (
4596 Make_Attribute_Reference (Loc,
4597 Prefix => New_Occurrence_Of (Ptyp, Loc),
4598 Attribute_Name => Name_Last)))))));
4600 Analyze_And_Resolve (N, Typ);
4606 when Attribute_Max =>
4607 Expand_Min_Max_Attribute (N);
4609 ----------------------------------
4610 -- Max_Size_In_Storage_Elements --
4611 ----------------------------------
4613 when Attribute_Max_Size_In_Storage_Elements => declare
4614 Typ : constant Entity_Id := Etype (N);
4617 Conversion_Added : Boolean := False;
4618 -- A flag which tracks whether the original attribute has been
4619 -- wrapped inside a type conversion.
4622 -- If the prefix is X'Class, we transform it into a direct reference
4623 -- to the class-wide type, because the back end must not see a 'Class
4624 -- reference. See also 'Size.
4626 if Is_Entity_Name (Pref)
4627 and then Is_Class_Wide_Type (Entity (Pref))
4629 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4633 Apply_Universal_Integer_Attribute_Checks (N);
4635 -- The universal integer check may sometimes add a type conversion,
4636 -- retrieve the original attribute reference from the expression.
4640 if Nkind (Attr) = N_Type_Conversion then
4641 Attr := Expression (Attr);
4642 Conversion_Added := True;
4645 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4647 -- Heap-allocated controlled objects contain two extra pointers which
4648 -- are not part of the actual type. Transform the attribute reference
4649 -- into a runtime expression to add the size of the hidden header.
4651 if Needs_Finalization (Ptyp)
4652 and then not Header_Size_Added (Attr)
4654 Set_Header_Size_Added (Attr);
4657 -- P'Max_Size_In_Storage_Elements +
4658 -- Universal_Integer
4659 -- (Header_Size_With_Padding (Ptyp'Alignment))
4663 Left_Opnd => Relocate_Node (Attr),
4665 Convert_To (Universal_Integer,
4666 Make_Function_Call (Loc,
4669 (RTE (RE_Header_Size_With_Padding), Loc),
4671 Parameter_Associations => New_List (
4672 Make_Attribute_Reference (Loc,
4674 New_Occurrence_Of (Ptyp, Loc),
4675 Attribute_Name => Name_Alignment))))));
4677 -- Add a conversion to the target type
4679 if not Conversion_Added then
4681 Make_Type_Conversion (Loc,
4682 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4683 Expression => Relocate_Node (Attr)));
4691 --------------------
4692 -- Mechanism_Code --
4693 --------------------
4695 when Attribute_Mechanism_Code =>
4697 -- We must replace the prefix in the renamed case
4699 if Is_Entity_Name (Pref)
4700 and then Present (Alias (Entity (Pref)))
4702 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4709 when Attribute_Min =>
4710 Expand_Min_Max_Attribute (N);
4716 when Attribute_Mod => Mod_Case : declare
4717 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4718 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4719 Modv : constant Uint := Modulus (Btyp);
4723 -- This is not so simple. The issue is what type to use for the
4724 -- computation of the modular value.
4726 -- The easy case is when the modulus value is within the bounds
4727 -- of the signed integer type of the argument. In this case we can
4728 -- just do the computation in that signed integer type, and then
4729 -- do an ordinary conversion to the target type.
4731 if Modv <= Expr_Value (Hi) then
4736 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4738 -- Here we know that the modulus is larger than type'Last of the
4739 -- integer type. There are two cases to consider:
4741 -- a) The integer value is non-negative. In this case, it is
4742 -- returned as the result (since it is less than the modulus).
4744 -- b) The integer value is negative. In this case, we know that the
4745 -- result is modulus + value, where the value might be as small as
4746 -- -modulus. The trouble is what type do we use to do the subtract.
4747 -- No type will do, since modulus can be as big as 2**64, and no
4748 -- integer type accommodates this value. Let's do bit of algebra
4751 -- = modulus - (-value)
4752 -- = (modulus - 1) - (-value - 1)
4754 -- Now modulus - 1 is certainly in range of the modular type.
4755 -- -value is in the range 1 .. modulus, so -value -1 is in the
4756 -- range 0 .. modulus-1 which is in range of the modular type.
4757 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4758 -- which we can compute using the integer base type.
4760 -- Once this is done we analyze the if expression without range
4761 -- checks, because we know everything is in range, and we want
4762 -- to prevent spurious warnings on either branch.
4766 Make_If_Expression (Loc,
4767 Expressions => New_List (
4769 Left_Opnd => Duplicate_Subexpr (Arg),
4770 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4773 Duplicate_Subexpr_No_Checks (Arg)),
4775 Make_Op_Subtract (Loc,
4777 Make_Integer_Literal (Loc,
4778 Intval => Modv - 1),
4784 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4786 Make_Integer_Literal (Loc,
4787 Intval => 1))))))));
4791 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4798 -- Transforms 'Model into a call to the floating-point attribute
4799 -- function Model in Fat_xxx (where xxx is the root type).
4800 -- Expansion is avoided for cases the back end can handle directly.
4802 when Attribute_Model =>
4803 if not Is_Inline_Floating_Point_Attribute (N) then
4804 Expand_Fpt_Attribute_R (N);
4811 -- The processing for Object_Size shares the processing for Size
4817 when Attribute_Old => Old : declare
4818 Typ : constant Entity_Id := Etype (N);
4819 CW_Temp : Entity_Id;
4826 -- Generating C code we don't need to expand this attribute when
4827 -- we are analyzing the internally built nested postconditions
4828 -- procedure since it will be expanded inline (and later it will
4829 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4830 -- performed in such case then the compiler generates unreferenced
4831 -- extra temporaries.
4833 if Modify_Tree_For_C
4834 and then Chars (Current_Scope) = Name_uPostconditions
4839 -- Climb the parent chain looking for subprogram _Postconditions
4842 while Present (Subp) loop
4843 exit when Nkind (Subp) = N_Subprogram_Body
4844 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4846 -- If assertions are disabled, no need to create the declaration
4847 -- that preserves the value. The postcondition pragma in which
4848 -- 'Old appears will be checked or disabled according to the
4849 -- current policy in effect.
4851 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4855 Subp := Parent (Subp);
4858 -- 'Old can only appear in a postcondition, the generated body of
4859 -- _Postconditions must be in the tree (or inlined if we are
4860 -- generating C code).
4864 or else (Modify_Tree_For_C and then In_Inlined_Body));
4866 Temp := Make_Temporary (Loc, 'T', Pref);
4868 -- Set the entity kind now in order to mark the temporary as a
4869 -- handler of attribute 'Old's prefix.
4871 Set_Ekind (Temp, E_Constant);
4872 Set_Stores_Attribute_Old_Prefix (Temp);
4874 -- Push the scope of the related subprogram where _Postcondition
4875 -- resides as this ensures that the object will be analyzed in the
4878 if Present (Subp) then
4879 Push_Scope (Scope (Defining_Entity (Subp)));
4881 -- No need to push the scope when generating C code since the
4882 -- _Postcondition procedure has been inlined.
4884 else pragma Assert (Modify_Tree_For_C);
4885 pragma Assert (In_Inlined_Body);
4889 -- Locate the insertion place of the internal temporary that saves
4892 if Present (Subp) then
4895 -- Generating C, the postcondition procedure has been inlined and the
4896 -- temporary is added before the first declaration of the enclosing
4899 else pragma Assert (Modify_Tree_For_C);
4901 while Nkind (Ins_Nod) /= N_Subprogram_Body loop
4902 Ins_Nod := Parent (Ins_Nod);
4905 Ins_Nod := First (Declarations (Ins_Nod));
4908 -- Preserve the tag of the prefix by offering a specific view of the
4909 -- class-wide version of the prefix.
4911 if Is_Tagged_Type (Typ) then
4914 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4916 CW_Temp := Make_Temporary (Loc, 'T');
4917 CW_Typ := Class_Wide_Type (Typ);
4919 Insert_Before_And_Analyze (Ins_Nod,
4920 Make_Object_Declaration (Loc,
4921 Defining_Identifier => CW_Temp,
4922 Constant_Present => True,
4923 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4925 Convert_To (CW_Typ, Relocate_Node (Pref))));
4928 -- Temp : Typ renames Typ (CW_Temp);
4930 Insert_Before_And_Analyze (Ins_Nod,
4931 Make_Object_Renaming_Declaration (Loc,
4932 Defining_Identifier => Temp,
4933 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4935 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4941 -- Temp : constant Typ := Pref;
4943 Insert_Before_And_Analyze (Ins_Nod,
4944 Make_Object_Declaration (Loc,
4945 Defining_Identifier => Temp,
4946 Constant_Present => True,
4947 Object_Definition => New_Occurrence_Of (Typ, Loc),
4948 Expression => Relocate_Node (Pref)));
4951 if Present (Subp) then
4955 -- Ensure that the prefix of attribute 'Old is valid. The check must
4956 -- be inserted after the expansion of the attribute has taken place
4957 -- to reflect the new placement of the prefix.
4959 if Validity_Checks_On and then Validity_Check_Operands then
4960 Ensure_Valid (Pref);
4963 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4966 ----------------------
4967 -- Overlaps_Storage --
4968 ----------------------
4970 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4971 Loc : constant Source_Ptr := Sloc (N);
4973 X : constant Node_Id := Prefix (N);
4974 Y : constant Node_Id := First (Expressions (N));
4977 X_Addr, Y_Addr : Node_Id;
4978 -- the expressions for their integer addresses
4980 X_Size, Y_Size : Node_Id;
4981 -- the expressions for their sizes
4986 -- Attribute expands into:
4988 -- if X'Address < Y'address then
4989 -- (X'address + X'Size - 1) >= Y'address
4991 -- (Y'address + Y'size - 1) >= X'Address
4994 -- with the proper address operations. We convert addresses to
4995 -- integer addresses to use predefined arithmetic. The size is
4996 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4997 -- to prevent the appearance of the same node in two places in
5001 Unchecked_Convert_To (RTE (RE_Integer_Address),
5002 Make_Attribute_Reference (Loc,
5003 Attribute_Name => Name_Address,
5004 Prefix => New_Copy_Tree (X)));
5007 Unchecked_Convert_To (RTE (RE_Integer_Address),
5008 Make_Attribute_Reference (Loc,
5009 Attribute_Name => Name_Address,
5010 Prefix => New_Copy_Tree (Y)));
5013 Make_Op_Divide (Loc,
5015 Make_Attribute_Reference (Loc,
5016 Attribute_Name => Name_Size,
5017 Prefix => New_Copy_Tree (X)),
5019 Make_Integer_Literal (Loc, System_Storage_Unit));
5022 Make_Op_Divide (Loc,
5024 Make_Attribute_Reference (Loc,
5025 Attribute_Name => Name_Size,
5026 Prefix => New_Copy_Tree (Y)),
5028 Make_Integer_Literal (Loc, System_Storage_Unit));
5032 Left_Opnd => X_Addr,
5033 Right_Opnd => Y_Addr);
5036 Make_If_Expression (Loc, New_List (
5042 Left_Opnd => New_Copy_Tree (X_Addr),
5044 Make_Op_Subtract (Loc,
5045 Left_Opnd => X_Size,
5046 Right_Opnd => Make_Integer_Literal (Loc, 1))),
5047 Right_Opnd => Y_Addr),
5052 Left_Opnd => New_Copy_Tree (Y_Addr),
5054 Make_Op_Subtract (Loc,
5055 Left_Opnd => Y_Size,
5056 Right_Opnd => Make_Integer_Literal (Loc, 1))),
5057 Right_Opnd => X_Addr))));
5059 Analyze_And_Resolve (N, Standard_Boolean);
5060 end Overlaps_Storage;
5066 when Attribute_Output => Output : declare
5067 P_Type : constant Entity_Id := Entity (Pref);
5068 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5076 -- If no underlying type, we have an error that will be diagnosed
5077 -- elsewhere, so here we just completely ignore the expansion.
5083 -- Stream operations can appear in user code even if the restriction
5084 -- No_Streams is active (for example, when instantiating a predefined
5085 -- container). In that case rewrite the attribute as a Raise to
5086 -- prevent any run-time use.
5088 if Restriction_Active (No_Streams) then
5090 Make_Raise_Program_Error (Sloc (N),
5091 Reason => PE_Stream_Operation_Not_Allowed));
5092 Set_Etype (N, Standard_Void_Type);
5096 -- If TSS for Output is present, just call it
5098 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
5100 if Present (Pname) then
5104 -- If there is a Stream_Convert pragma, use it, we rewrite
5106 -- sourcetyp'Output (stream, Item)
5110 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5112 -- where strmwrite is the given Write function that converts an
5113 -- argument of type sourcetyp or a type acctyp, from which it is
5114 -- derived to type strmtyp. The conversion to acttyp is required
5115 -- for the derived case.
5117 Prag := Get_Stream_Convert_Pragma (P_Type);
5119 if Present (Prag) then
5121 Next (Next (First (Pragma_Argument_Associations (Prag))));
5122 Wfunc := Entity (Expression (Arg3));
5125 Make_Attribute_Reference (Loc,
5126 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5127 Attribute_Name => Name_Output,
5128 Expressions => New_List (
5129 Relocate_Node (First (Exprs)),
5130 Make_Function_Call (Loc,
5131 Name => New_Occurrence_Of (Wfunc, Loc),
5132 Parameter_Associations => New_List (
5133 OK_Convert_To (Etype (First_Formal (Wfunc)),
5134 Relocate_Node (Next (First (Exprs)))))))));
5139 -- For elementary types, we call the W_xxx routine directly. Note
5140 -- that the effect of Write and Output is identical for the case
5141 -- of an elementary type (there are no discriminants or bounds).
5143 elsif Is_Elementary_Type (U_Type) then
5145 -- A special case arises if we have a defined _Write routine,
5146 -- since in this case we are required to call this routine.
5149 Typ : Entity_Id := P_Type;
5151 if Present (Full_View (Typ)) then
5152 Typ := Full_View (Typ);
5155 if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
5156 Build_Record_Or_Elementary_Output_Procedure
5157 (Loc, Typ, Decl, Pname);
5158 Insert_Action (N, Decl);
5160 -- For normal cases, we call the W_xxx routine directly
5163 Rewrite (N, Build_Elementary_Write_Call (N));
5171 elsif Is_Array_Type (U_Type) then
5172 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
5173 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5175 -- Class-wide case, first output external tag, then dispatch
5176 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5178 elsif Is_Class_Wide_Type (P_Type) then
5180 -- No need to do anything else compiling under restriction
5181 -- No_Dispatching_Calls. During the semantic analysis we
5182 -- already notified such violation.
5184 if Restriction_Active (No_Dispatching_Calls) then
5189 Strm : constant Node_Id := First (Exprs);
5190 Item : constant Node_Id := Next (Strm);
5193 -- Ada 2005 (AI-344): Check that the accessibility level
5194 -- of the type of the output object is not deeper than
5195 -- that of the attribute's prefix type.
5197 -- if Get_Access_Level (Item'Tag)
5198 -- /= Get_Access_Level (P_Type'Tag)
5203 -- String'Output (Strm, External_Tag (Item'Tag));
5205 -- We cannot figure out a practical way to implement this
5206 -- accessibility check on virtual machines, so we omit it.
5208 if Ada_Version >= Ada_2005
5209 and then Tagged_Type_Expansion
5212 Make_Implicit_If_Statement (N,
5216 Build_Get_Access_Level (Loc,
5217 Make_Attribute_Reference (Loc,
5220 Duplicate_Subexpr (Item,
5222 Attribute_Name => Name_Tag)),
5225 Make_Integer_Literal (Loc,
5226 Type_Access_Level (P_Type))),
5229 New_List (Make_Raise_Statement (Loc,
5231 RTE (RE_Tag_Error), Loc)))));
5235 Make_Attribute_Reference (Loc,
5236 Prefix => New_Occurrence_Of (Standard_String, Loc),
5237 Attribute_Name => Name_Output,
5238 Expressions => New_List (
5239 Relocate_Node (Duplicate_Subexpr (Strm)),
5240 Make_Function_Call (Loc,
5242 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
5243 Parameter_Associations => New_List (
5244 Make_Attribute_Reference (Loc,
5247 (Duplicate_Subexpr (Item, Name_Req => True)),
5248 Attribute_Name => Name_Tag))))));
5251 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
5253 -- Tagged type case, use the primitive Output function
5255 elsif Is_Tagged_Type (U_Type) then
5256 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
5258 -- All other record type cases, including protected records.
5259 -- The latter only arise for expander generated code for
5260 -- handling shared passive partition access.
5264 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5266 -- Ada 2005 (AI-216): Program_Error is raised when executing
5267 -- the default implementation of the Output attribute of an
5268 -- unchecked union type if the type lacks default discriminant
5271 if Is_Unchecked_Union (Base_Type (U_Type))
5272 and then No (Discriminant_Constraint (U_Type))
5275 Make_Raise_Program_Error (Loc,
5276 Reason => PE_Unchecked_Union_Restriction));
5281 Build_Record_Or_Elementary_Output_Procedure
5282 (Loc, Base_Type (U_Type), Decl, Pname);
5283 Insert_Action (N, Decl);
5287 -- If we fall through, Pname is the name of the procedure to call
5289 Rewrite_Stream_Proc_Call (Pname);
5296 -- For enumeration types with a standard representation, Pos is
5297 -- handled by the back end.
5299 -- For enumeration types, with a non-standard representation we generate
5300 -- a call to the _Rep_To_Pos function created when the type was frozen.
5301 -- The call has the form
5303 -- _rep_to_pos (expr, flag)
5305 -- The parameter flag is True if range checks are enabled, causing
5306 -- Program_Error to be raised if the expression has an invalid
5307 -- representation, and False if range checks are suppressed.
5309 -- For integer types, Pos is equivalent to a simple integer
5310 -- conversion and we rewrite it as such
5312 when Attribute_Pos => Pos : declare
5313 Etyp : Entity_Id := Base_Type (Entity (Pref));
5316 -- Deal with zero/non-zero boolean values
5318 if Is_Boolean_Type (Etyp) then
5319 Adjust_Condition (First (Exprs));
5320 Etyp := Standard_Boolean;
5321 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
5324 -- Case of enumeration type
5326 if Is_Enumeration_Type (Etyp) then
5328 -- Non-standard enumeration type (generate call)
5330 if Present (Enum_Pos_To_Rep (Etyp)) then
5331 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
5334 Make_Function_Call (Loc,
5336 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5337 Parameter_Associations => Exprs)));
5339 Analyze_And_Resolve (N, Typ);
5341 -- Standard enumeration type (do universal integer check)
5344 Apply_Universal_Integer_Attribute_Checks (N);
5347 -- Deal with integer types (replace by conversion)
5349 elsif Is_Integer_Type (Etyp) then
5350 Rewrite (N, Convert_To (Typ, First (Exprs)));
5351 Analyze_And_Resolve (N, Typ);
5360 -- We compute this if a component clause was present, otherwise we leave
5361 -- the computation up to the back end, since we don't know what layout
5364 when Attribute_Position => Position_Attr : declare
5365 CE : constant Entity_Id := Entity (Selector_Name (Pref));
5368 if Present (Component_Clause (CE)) then
5370 -- In Ada 2005 (or later) if we have the non-default bit order,
5371 -- then we return the original value as given in the component
5372 -- clause (RM 2005 13.5.2(2/2)).
5374 if Ada_Version >= Ada_2005
5375 and then Reverse_Bit_Order (Scope (CE))
5378 Make_Integer_Literal (Loc,
5379 Intval => Expr_Value (Position (Component_Clause (CE)))));
5381 -- Otherwise (Ada 83 or 95, or default bit order specified in
5382 -- later Ada version), return the normalized value.
5386 Make_Integer_Literal (Loc,
5387 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
5390 Analyze_And_Resolve (N, Typ);
5392 -- If back end is doing things, just apply universal integer checks
5395 Apply_Universal_Integer_Attribute_Checks (N);
5403 -- 1. Deal with enumeration types with holes.
5404 -- 2. For floating-point, generate call to attribute function.
5405 -- 3. For other cases, deal with constraint checking.
5407 when Attribute_Pred => Pred : declare
5408 Etyp : constant Entity_Id := Base_Type (Ptyp);
5412 -- For enumeration types with non-standard representations, we
5413 -- expand typ'Pred (x) into
5415 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5417 -- If the representation is contiguous, we compute instead
5418 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5419 -- The conversion function Enum_Pos_To_Rep is defined on the
5420 -- base type, not the subtype, so we have to use the base type
5421 -- explicitly for this and other enumeration attributes.
5423 if Is_Enumeration_Type (Ptyp)
5424 and then Present (Enum_Pos_To_Rep (Etyp))
5426 if Has_Contiguous_Rep (Etyp) then
5428 Unchecked_Convert_To (Ptyp,
5431 Make_Integer_Literal (Loc,
5432 Enumeration_Rep (First_Literal (Ptyp))),
5434 Make_Function_Call (Loc,
5437 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5439 Parameter_Associations =>
5441 Unchecked_Convert_To (Ptyp,
5442 Make_Op_Subtract (Loc,
5444 Unchecked_Convert_To (Standard_Integer,
5445 Relocate_Node (First (Exprs))),
5447 Make_Integer_Literal (Loc, 1))),
5448 Rep_To_Pos_Flag (Ptyp, Loc))))));
5451 -- Add Boolean parameter True, to request program errror if
5452 -- we have a bad representation on our hands. If checks are
5453 -- suppressed, then add False instead
5455 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5457 Make_Indexed_Component (Loc,
5460 (Enum_Pos_To_Rep (Etyp), Loc),
5461 Expressions => New_List (
5462 Make_Op_Subtract (Loc,
5464 Make_Function_Call (Loc,
5467 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5468 Parameter_Associations => Exprs),
5469 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5472 Analyze_And_Resolve (N, Typ);
5474 -- For floating-point, we transform 'Pred into a call to the Pred
5475 -- floating-point attribute function in Fat_xxx (xxx is root type).
5476 -- Note that this function takes care of the overflow case.
5478 elsif Is_Floating_Point_Type (Ptyp) then
5479 Expand_Fpt_Attribute_R (N);
5480 Analyze_And_Resolve (N, Typ);
5482 -- For modular types, nothing to do (no overflow, since wraps)
5484 elsif Is_Modular_Integer_Type (Ptyp) then
5487 -- For other types, if argument is marked as needing a range check or
5488 -- overflow checking is enabled, we must generate a check.
5490 elsif not Overflow_Checks_Suppressed (Ptyp)
5491 or else Do_Range_Check (First (Exprs))
5493 Set_Do_Range_Check (First (Exprs), False);
5494 Expand_Pred_Succ_Attribute (N);
5502 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5504 -- We rewrite X'Priority as the following run-time call:
5506 -- Get_Ceiling (X._Object)
5508 -- Note that although X'Priority is notionally an object, it is quite
5509 -- deliberately not defined as an aliased object in the RM. This means
5510 -- that it works fine to rewrite it as a call, without having to worry
5511 -- about complications that would other arise from X'Priority'Access,
5512 -- which is illegal, because of the lack of aliasing.
5514 when Attribute_Priority => Priority : declare
5516 Conctyp : Entity_Id;
5517 New_Itype : Entity_Id;
5518 Object_Parm : Node_Id;
5520 RT_Subprg_Name : Node_Id;
5523 -- Look for the enclosing concurrent type
5525 Conctyp := Current_Scope;
5526 while not Is_Concurrent_Type (Conctyp) loop
5527 Conctyp := Scope (Conctyp);
5530 pragma Assert (Is_Protected_Type (Conctyp));
5532 -- Generate the actual of the call
5534 Subprg := Current_Scope;
5535 while not Present (Protected_Body_Subprogram (Subprg)) loop
5536 Subprg := Scope (Subprg);
5539 -- Use of 'Priority inside protected entries and barriers (in both
5540 -- cases the type of the first formal of their expanded subprogram
5543 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5546 -- In the expansion of protected entries the type of the first
5547 -- formal of the Protected_Body_Subprogram is an Address. In order
5548 -- to reference the _object component we generate:
5550 -- type T is access p__ptTV;
5553 New_Itype := Create_Itype (E_Access_Type, N);
5554 Set_Etype (New_Itype, New_Itype);
5555 Set_Directly_Designated_Type (New_Itype,
5556 Corresponding_Record_Type (Conctyp));
5557 Freeze_Itype (New_Itype, N);
5560 -- T!(O)._object'unchecked_access
5563 Make_Attribute_Reference (Loc,
5565 Make_Selected_Component (Loc,
5567 Unchecked_Convert_To (New_Itype,
5569 (First_Entity (Protected_Body_Subprogram (Subprg)),
5571 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5572 Attribute_Name => Name_Unchecked_Access);
5574 -- Use of 'Priority inside a protected subprogram
5578 Make_Attribute_Reference (Loc,
5580 Make_Selected_Component (Loc,
5583 (First_Entity (Protected_Body_Subprogram (Subprg)),
5585 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5586 Attribute_Name => Name_Unchecked_Access);
5589 -- Select the appropriate run-time subprogram
5591 if Number_Entries (Conctyp) = 0 then
5592 RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5594 RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5598 Make_Function_Call (Loc,
5599 Name => RT_Subprg_Name,
5600 Parameter_Associations => New_List (Object_Parm));
5604 -- Avoid the generation of extra checks on the pointer to the
5605 -- protected object.
5607 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5614 when Attribute_Range_Length =>
5616 -- The only special processing required is for the case where
5617 -- Range_Length is applied to an enumeration type with holes.
5618 -- In this case we transform
5624 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5626 -- So that the result reflects the proper Pos values instead
5627 -- of the underlying representations.
5629 if Is_Enumeration_Type (Ptyp)
5630 and then Has_Non_Standard_Rep (Ptyp)
5635 Make_Op_Subtract (Loc,
5637 Make_Attribute_Reference (Loc,
5638 Attribute_Name => Name_Pos,
5639 Prefix => New_Occurrence_Of (Ptyp, Loc),
5640 Expressions => New_List (
5641 Make_Attribute_Reference (Loc,
5642 Attribute_Name => Name_Last,
5644 New_Occurrence_Of (Ptyp, Loc)))),
5647 Make_Attribute_Reference (Loc,
5648 Attribute_Name => Name_Pos,
5649 Prefix => New_Occurrence_Of (Ptyp, Loc),
5650 Expressions => New_List (
5651 Make_Attribute_Reference (Loc,
5652 Attribute_Name => Name_First,
5654 New_Occurrence_Of (Ptyp, Loc))))),
5656 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5658 Analyze_And_Resolve (N, Typ);
5660 -- For all other cases, the attribute is handled by the back end, but
5661 -- we need to deal with the case of the range check on a universal
5665 Apply_Universal_Integer_Attribute_Checks (N);
5672 when Attribute_Read => Read : declare
5673 P_Type : constant Entity_Id := Entity (Pref);
5674 B_Type : constant Entity_Id := Base_Type (P_Type);
5675 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5685 -- If no underlying type, we have an error that will be diagnosed
5686 -- elsewhere, so here we just completely ignore the expansion.
5692 -- Stream operations can appear in user code even if the restriction
5693 -- No_Streams is active (for example, when instantiating a predefined
5694 -- container). In that case rewrite the attribute as a Raise to
5695 -- prevent any run-time use.
5697 if Restriction_Active (No_Streams) then
5699 Make_Raise_Program_Error (Sloc (N),
5700 Reason => PE_Stream_Operation_Not_Allowed));
5701 Set_Etype (N, B_Type);
5705 -- The simple case, if there is a TSS for Read, just call it
5707 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5709 if Present (Pname) then
5713 -- If there is a Stream_Convert pragma, use it, we rewrite
5715 -- sourcetyp'Read (stream, Item)
5719 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5721 -- where strmread is the given Read function that converts an
5722 -- argument of type strmtyp to type sourcetyp or a type from which
5723 -- it is derived. The conversion to sourcetyp is required in the
5726 -- A special case arises if Item is a type conversion in which
5727 -- case, we have to expand to:
5729 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5731 -- where Itemx is the expression of the type conversion (i.e.
5732 -- the actual object), and typex is the type of Itemx.
5734 Prag := Get_Stream_Convert_Pragma (P_Type);
5736 if Present (Prag) then
5737 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5738 Rfunc := Entity (Expression (Arg2));
5739 Lhs := Relocate_Node (Next (First (Exprs)));
5741 OK_Convert_To (B_Type,
5742 Make_Function_Call (Loc,
5743 Name => New_Occurrence_Of (Rfunc, Loc),
5744 Parameter_Associations => New_List (
5745 Make_Attribute_Reference (Loc,
5748 (Etype (First_Formal (Rfunc)), Loc),
5749 Attribute_Name => Name_Input,
5750 Expressions => New_List (
5751 Relocate_Node (First (Exprs)))))));
5753 if Nkind (Lhs) = N_Type_Conversion then
5754 Lhs := Expression (Lhs);
5755 Rhs := Convert_To (Etype (Lhs), Rhs);
5759 Make_Assignment_Statement (Loc,
5761 Expression => Rhs));
5762 Set_Assignment_OK (Lhs);
5766 -- For elementary types, we call the I_xxx routine using the first
5767 -- parameter and then assign the result into the second parameter.
5768 -- We set Assignment_OK to deal with the conversion case.
5770 elsif Is_Elementary_Type (U_Type) then
5776 Lhs := Relocate_Node (Next (First (Exprs)));
5777 Rhs := Build_Elementary_Input_Call (N);
5779 if Nkind (Lhs) = N_Type_Conversion then
5780 Lhs := Expression (Lhs);
5781 Rhs := Convert_To (Etype (Lhs), Rhs);
5784 Set_Assignment_OK (Lhs);
5787 Make_Assignment_Statement (Loc,
5789 Expression => Rhs));
5797 elsif Is_Array_Type (U_Type) then
5798 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5799 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5801 -- Tagged type case, use the primitive Read function. Note that
5802 -- this will dispatch in the class-wide case which is what we want
5804 elsif Is_Tagged_Type (U_Type) then
5805 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5807 -- All other record type cases, including protected records. The
5808 -- latter only arise for expander generated code for handling
5809 -- shared passive partition access.
5813 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5815 -- Ada 2005 (AI-216): Program_Error is raised when executing
5816 -- the default implementation of the Read attribute of an
5817 -- Unchecked_Union type. We replace the attribute with a
5818 -- raise statement (rather than inserting it before) to handle
5819 -- properly the case of an unchecked union that is a record
5822 if Is_Unchecked_Union (Base_Type (U_Type)) then
5824 Make_Raise_Program_Error (Loc,
5825 Reason => PE_Unchecked_Union_Restriction));
5826 Set_Etype (N, B_Type);
5830 if Has_Discriminants (U_Type)
5832 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5834 Build_Mutable_Record_Read_Procedure
5835 (Loc, Full_Base (U_Type), Decl, Pname);
5837 Build_Record_Read_Procedure
5838 (Loc, Full_Base (U_Type), Decl, Pname);
5841 -- Suppress checks, uninitialized or otherwise invalid
5842 -- data does not cause constraint errors to be raised for
5843 -- a complete record read.
5845 Insert_Action (N, Decl, All_Checks);
5849 Rewrite_Stream_Proc_Call (Pname);
5856 -- Ref is identical to To_Address, see To_Address for processing
5862 -- Transforms 'Remainder into a call to the floating-point attribute
5863 -- function Remainder in Fat_xxx (where xxx is the root type)
5865 when Attribute_Remainder =>
5866 Expand_Fpt_Attribute_RR (N);
5872 -- Transform 'Result into reference to _Result formal. At the point
5873 -- where a legal 'Result attribute is expanded, we know that we are in
5874 -- the context of a _Postcondition function with a _Result parameter.
5876 when Attribute_Result =>
5877 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5878 Analyze_And_Resolve (N, Typ);
5884 -- The handling of the Round attribute is quite delicate. The processing
5885 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5886 -- semantics of Round, but we do not want anything to do with universal
5887 -- real at runtime, since this corresponds to using floating-point
5890 -- What we have now is that the Etype of the Round attribute correctly
5891 -- indicates the final result type. The operand of the Round is the
5892 -- conversion to universal real, described above, and the operand of
5893 -- this conversion is the actual operand of Round, which may be the
5894 -- special case of a fixed point multiplication or division (Etype =
5897 -- The exapander will expand first the operand of the conversion, then
5898 -- the conversion, and finally the round attribute itself, since we
5899 -- always work inside out. But we cannot simply process naively in this
5900 -- order. In the semantic world where universal fixed and real really
5901 -- exist and have infinite precision, there is no problem, but in the
5902 -- implementation world, where universal real is a floating-point type,
5903 -- we would get the wrong result.
5905 -- So the approach is as follows. First, when expanding a multiply or
5906 -- divide whose type is universal fixed, we do nothing at all, instead
5907 -- deferring the operation till later.
5909 -- The actual processing is done in Expand_N_Type_Conversion which
5910 -- handles the special case of Round by looking at its parent to see if
5911 -- it is a Round attribute, and if it is, handling the conversion (or
5912 -- its fixed multiply/divide child) in an appropriate manner.
5914 -- This means that by the time we get to expanding the Round attribute
5915 -- itself, the Round is nothing more than a type conversion (and will
5916 -- often be a null type conversion), so we just replace it with the
5917 -- appropriate conversion operation.
5919 when Attribute_Round =>
5921 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5922 Analyze_And_Resolve (N);
5928 -- Transforms 'Rounding into a call to the floating-point attribute
5929 -- function Rounding in Fat_xxx (where xxx is the root type)
5930 -- Expansion is avoided for cases the back end can handle directly.
5932 when Attribute_Rounding =>
5933 if not Is_Inline_Floating_Point_Attribute (N) then
5934 Expand_Fpt_Attribute_R (N);
5941 -- Transforms 'Scaling into a call to the floating-point attribute
5942 -- function Scaling in Fat_xxx (where xxx is the root type)
5944 when Attribute_Scaling =>
5945 Expand_Fpt_Attribute_RI (N);
5947 -------------------------
5948 -- Simple_Storage_Pool --
5949 -------------------------
5951 when Attribute_Simple_Storage_Pool =>
5953 Make_Type_Conversion (Loc,
5954 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5955 Expression => New_Occurrence_Of (Entity (N), Loc)));
5956 Analyze_And_Resolve (N, Typ);
5962 when Attribute_Object_Size
5964 | Attribute_Value_Size
5965 | Attribute_VADS_Size
5972 -- Processing for VADS_Size case. Note that this processing
5973 -- removes all traces of VADS_Size from the tree, and completes
5974 -- all required processing for VADS_Size by translating the
5975 -- attribute reference to an appropriate Size or Object_Size
5978 if Id = Attribute_VADS_Size
5979 or else (Use_VADS_Size and then Id = Attribute_Size)
5981 -- If the size is specified, then we simply use the specified
5982 -- size. This applies to both types and objects. The size of an
5983 -- object can be specified in the following ways:
5985 -- An explicit size object is given for an object
5986 -- A component size is specified for an indexed component
5987 -- A component clause is specified for a selected component
5988 -- The object is a component of a packed composite object
5990 -- If the size is specified, then VADS_Size of an object
5992 if (Is_Entity_Name (Pref)
5993 and then Present (Size_Clause (Entity (Pref))))
5995 (Nkind (Pref) = N_Component_Clause
5996 and then (Present (Component_Clause
5997 (Entity (Selector_Name (Pref))))
5998 or else Is_Packed (Etype (Prefix (Pref)))))
6000 (Nkind (Pref) = N_Indexed_Component
6001 and then (Component_Size (Etype (Prefix (Pref))) /= 0
6002 or else Is_Packed (Etype (Prefix (Pref)))))
6004 Set_Attribute_Name (N, Name_Size);
6006 -- Otherwise if we have an object rather than a type, then
6007 -- the VADS_Size attribute applies to the type of the object,
6008 -- rather than the object itself. This is one of the respects
6009 -- in which VADS_Size differs from Size.
6012 if (not Is_Entity_Name (Pref)
6013 or else not Is_Type (Entity (Pref)))
6014 and then (Is_Scalar_Type (Ptyp)
6015 or else Is_Constrained (Ptyp))
6017 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
6020 -- For a scalar type for which no size was explicitly given,
6021 -- VADS_Size means Object_Size. This is the other respect in
6022 -- which VADS_Size differs from Size.
6024 if Is_Scalar_Type (Ptyp)
6025 and then No (Size_Clause (Ptyp))
6027 Set_Attribute_Name (N, Name_Object_Size);
6029 -- In all other cases, Size and VADS_Size are the sane
6032 Set_Attribute_Name (N, Name_Size);
6037 -- If the prefix is X'Class, transform it into a direct reference
6038 -- to the class-wide type, because the back end must not see a
6039 -- 'Class reference.
6041 if Is_Entity_Name (Pref)
6042 and then Is_Class_Wide_Type (Entity (Pref))
6044 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
6047 -- For X'Size applied to an object of a class-wide type, transform
6048 -- X'Size into a call to the primitive operation _Size applied to
6051 elsif Is_Class_Wide_Type (Ptyp) then
6053 -- No need to do anything else compiling under restriction
6054 -- No_Dispatching_Calls. During the semantic analysis we
6055 -- already noted this restriction violation.
6057 if Restriction_Active (No_Dispatching_Calls) then
6062 Make_Function_Call (Loc,
6064 New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc),
6065 Parameter_Associations => New_List (Pref));
6067 if Typ /= Standard_Long_Long_Integer then
6069 -- The context is a specific integer type with which the
6070 -- original attribute was compatible. The function has a
6071 -- specific type as well, so to preserve the compatibility
6072 -- we must convert explicitly.
6074 New_Node := Convert_To (Typ, New_Node);
6077 Rewrite (N, New_Node);
6078 Analyze_And_Resolve (N, Typ);
6081 -- Case of known RM_Size of a type
6083 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
6084 and then Is_Entity_Name (Pref)
6085 and then Is_Type (Entity (Pref))
6086 and then Known_Static_RM_Size (Entity (Pref))
6088 Siz := RM_Size (Entity (Pref));
6090 -- Case of known Esize of a type
6092 elsif Id = Attribute_Object_Size
6093 and then Is_Entity_Name (Pref)
6094 and then Is_Type (Entity (Pref))
6095 and then Known_Static_Esize (Entity (Pref))
6097 Siz := Esize (Entity (Pref));
6099 -- Case of known size of object
6101 elsif Id = Attribute_Size
6102 and then Is_Entity_Name (Pref)
6103 and then Is_Object (Entity (Pref))
6104 and then Known_Esize (Entity (Pref))
6105 and then Known_Static_Esize (Entity (Pref))
6107 Siz := Esize (Entity (Pref));
6109 -- For an array component, we can do Size in the front end if the
6110 -- component_size of the array is set.
6112 elsif Nkind (Pref) = N_Indexed_Component then
6113 Siz := Component_Size (Etype (Prefix (Pref)));
6115 -- For a record component, we can do Size in the front end if
6116 -- there is a component clause, or if the record is packed and the
6117 -- component's size is known at compile time.
6119 elsif Nkind (Pref) = N_Selected_Component then
6121 Rec : constant Entity_Id := Etype (Prefix (Pref));
6122 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
6125 if Present (Component_Clause (Comp)) then
6126 Siz := Esize (Comp);
6128 elsif Is_Packed (Rec) then
6129 Siz := RM_Size (Ptyp);
6132 Apply_Universal_Integer_Attribute_Checks (N);
6137 -- All other cases are handled by the back end
6140 Apply_Universal_Integer_Attribute_Checks (N);
6142 -- If Size is applied to a formal parameter that is of a packed
6143 -- array subtype, then apply Size to the actual subtype.
6145 if Is_Entity_Name (Pref)
6146 and then Is_Formal (Entity (Pref))
6147 and then Is_Array_Type (Ptyp)
6148 and then Is_Packed (Ptyp)
6151 Make_Attribute_Reference (Loc,
6153 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
6154 Attribute_Name => Name_Size));
6155 Analyze_And_Resolve (N, Typ);
6158 -- If Size applies to a dereference of an access to
6159 -- unconstrained packed array, the back end needs to see its
6160 -- unconstrained nominal type, but also a hint to the actual
6161 -- constrained type.
6163 if Nkind (Pref) = N_Explicit_Dereference
6164 and then Is_Array_Type (Ptyp)
6165 and then not Is_Constrained (Ptyp)
6166 and then Is_Packed (Ptyp)
6168 Set_Actual_Designated_Subtype (Pref,
6169 Get_Actual_Subtype (Pref));
6175 -- Common processing for record and array component case
6177 if Siz /= No_Uint and then Siz /= 0 then
6179 CS : constant Boolean := Comes_From_Source (N);
6182 Rewrite (N, Make_Integer_Literal (Loc, Siz));
6184 -- This integer literal is not a static expression. We do
6185 -- not call Analyze_And_Resolve here, because this would
6186 -- activate the circuit for deciding that a static value
6187 -- was out of range, and we don't want that.
6189 -- So just manually set the type, mark the expression as
6190 -- non-static, and then ensure that the result is checked
6191 -- properly if the attribute comes from source (if it was
6192 -- internally generated, we never need a constraint check).
6195 Set_Is_Static_Expression (N, False);
6198 Apply_Constraint_Check (N, Typ);
6208 when Attribute_Storage_Pool =>
6210 Make_Type_Conversion (Loc,
6211 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
6212 Expression => New_Occurrence_Of (Entity (N), Loc)));
6213 Analyze_And_Resolve (N, Typ);
6219 when Attribute_Storage_Size => Storage_Size : declare
6220 Alloc_Op : Entity_Id := Empty;
6224 -- Access type case, always go to the root type
6226 -- The case of access types results in a value of zero for the case
6227 -- where no storage size attribute clause has been given. If a
6228 -- storage size has been given, then the attribute is converted
6229 -- to a reference to the variable used to hold this value.
6231 if Is_Access_Type (Ptyp) then
6232 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
6234 Make_Attribute_Reference (Loc,
6235 Prefix => New_Occurrence_Of (Typ, Loc),
6236 Attribute_Name => Name_Max,
6237 Expressions => New_List (
6238 Make_Integer_Literal (Loc, 0),
6241 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
6243 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
6245 -- If the access type is associated with a simple storage pool
6246 -- object, then attempt to locate the optional Storage_Size
6247 -- function of the simple storage pool type. If not found,
6248 -- then the result will default to zero.
6250 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
6251 Name_Simple_Storage_Pool_Type))
6254 Pool_Type : constant Entity_Id :=
6255 Base_Type (Etype (Entity (N)));
6258 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
6259 while Present (Alloc_Op) loop
6260 if Scope (Alloc_Op) = Scope (Pool_Type)
6261 and then Present (First_Formal (Alloc_Op))
6262 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
6267 Alloc_Op := Homonym (Alloc_Op);
6271 -- In the normal Storage_Pool case, retrieve the primitive
6272 -- function associated with the pool type.
6277 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
6278 Attribute_Name (N));
6281 -- If Storage_Size wasn't found (can only occur in the simple
6282 -- storage pool case), then simply use zero for the result.
6284 if not Present (Alloc_Op) then
6285 Rewrite (N, Make_Integer_Literal (Loc, 0));
6287 -- Otherwise, rewrite the allocator as a call to pool type's
6288 -- Storage_Size function.
6293 Make_Function_Call (Loc,
6295 New_Occurrence_Of (Alloc_Op, Loc),
6297 Parameter_Associations => New_List (
6299 (Associated_Storage_Pool
6300 (Root_Type (Ptyp)), Loc)))));
6304 Rewrite (N, Make_Integer_Literal (Loc, 0));
6307 Analyze_And_Resolve (N, Typ);
6309 -- For tasks, we retrieve the size directly from the TCB. The
6310 -- size may depend on a discriminant of the type, and therefore
6311 -- can be a per-object expression, so type-level information is
6312 -- not sufficient in general. There are four cases to consider:
6314 -- a) If the attribute appears within a task body, the designated
6315 -- TCB is obtained by a call to Self.
6317 -- b) If the prefix of the attribute is the name of a task object,
6318 -- the designated TCB is the one stored in the corresponding record.
6320 -- c) If the prefix is a task type, the size is obtained from the
6321 -- size variable created for each task type
6323 -- d) If no Storage_Size was specified for the type, there is no
6324 -- size variable, and the value is a system-specific default.
6327 if In_Open_Scopes (Ptyp) then
6329 -- Storage_Size (Self)
6333 Make_Function_Call (Loc,
6335 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6336 Parameter_Associations =>
6338 Make_Function_Call (Loc,
6340 New_Occurrence_Of (RTE (RE_Self), Loc))))));
6342 elsif not Is_Entity_Name (Pref)
6343 or else not Is_Type (Entity (Pref))
6345 -- Storage_Size (Rec (Obj).Size)
6349 Make_Function_Call (Loc,
6351 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6352 Parameter_Associations =>
6354 Make_Selected_Component (Loc,
6356 Unchecked_Convert_To (
6357 Corresponding_Record_Type (Ptyp),
6358 New_Copy_Tree (Pref)),
6360 Make_Identifier (Loc, Name_uTask_Id))))));
6362 elsif Present (Storage_Size_Variable (Ptyp)) then
6364 -- Static Storage_Size pragma given for type: retrieve value
6365 -- from its allocated storage variable.
6369 Make_Function_Call (Loc,
6370 Name => New_Occurrence_Of (
6371 RTE (RE_Adjust_Storage_Size), Loc),
6372 Parameter_Associations =>
6375 Storage_Size_Variable (Ptyp), Loc)))));
6377 -- Get system default
6381 Make_Function_Call (Loc,
6384 RTE (RE_Default_Stack_Size), Loc))));
6387 Analyze_And_Resolve (N, Typ);
6395 when Attribute_Stream_Size =>
6397 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
6398 Analyze_And_Resolve (N, Typ);
6404 -- 1. Deal with enumeration types with holes.
6405 -- 2. For floating-point, generate call to attribute function.
6406 -- 3. For other cases, deal with constraint checking.
6408 when Attribute_Succ => Succ : declare
6409 Etyp : constant Entity_Id := Base_Type (Ptyp);
6412 -- For enumeration types with non-standard representations, we
6413 -- expand typ'Succ (x) into
6415 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6417 -- If the representation is contiguous, we compute instead
6418 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6420 if Is_Enumeration_Type (Ptyp)
6421 and then Present (Enum_Pos_To_Rep (Etyp))
6423 if Has_Contiguous_Rep (Etyp) then
6425 Unchecked_Convert_To (Ptyp,
6428 Make_Integer_Literal (Loc,
6429 Enumeration_Rep (First_Literal (Ptyp))),
6431 Make_Function_Call (Loc,
6434 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6436 Parameter_Associations =>
6438 Unchecked_Convert_To (Ptyp,
6441 Unchecked_Convert_To (Standard_Integer,
6442 Relocate_Node (First (Exprs))),
6444 Make_Integer_Literal (Loc, 1))),
6445 Rep_To_Pos_Flag (Ptyp, Loc))))));
6447 -- Add Boolean parameter True, to request program errror if
6448 -- we have a bad representation on our hands. Add False if
6449 -- checks are suppressed.
6451 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
6453 Make_Indexed_Component (Loc,
6456 (Enum_Pos_To_Rep (Etyp), Loc),
6457 Expressions => New_List (
6460 Make_Function_Call (Loc,
6463 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6464 Parameter_Associations => Exprs),
6465 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
6468 Analyze_And_Resolve (N, Typ);
6470 -- For floating-point, we transform 'Succ into a call to the Succ
6471 -- floating-point attribute function in Fat_xxx (xxx is root type)
6473 elsif Is_Floating_Point_Type (Ptyp) then
6474 Expand_Fpt_Attribute_R (N);
6475 Analyze_And_Resolve (N, Typ);
6477 -- For modular types, nothing to do (no overflow, since wraps)
6479 elsif Is_Modular_Integer_Type (Ptyp) then
6482 -- For other types, if argument is marked as needing a range check or
6483 -- overflow checking is enabled, we must generate a check.
6485 elsif not Overflow_Checks_Suppressed (Ptyp)
6486 or else Do_Range_Check (First (Exprs))
6488 Set_Do_Range_Check (First (Exprs), False);
6489 Expand_Pred_Succ_Attribute (N);
6497 -- Transforms X'Tag into a direct reference to the tag of X
6499 when Attribute_Tag => Tag : declare
6501 Prefix_Is_Type : Boolean;
6504 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6505 Ttyp := Entity (Pref);
6506 Prefix_Is_Type := True;
6509 Prefix_Is_Type := False;
6512 if Is_Class_Wide_Type (Ttyp) then
6513 Ttyp := Root_Type (Ttyp);
6516 Ttyp := Underlying_Type (Ttyp);
6518 -- Ada 2005: The type may be a synchronized tagged type, in which
6519 -- case the tag information is stored in the corresponding record.
6521 if Is_Concurrent_Type (Ttyp) then
6522 Ttyp := Corresponding_Record_Type (Ttyp);
6525 if Prefix_Is_Type then
6527 -- For VMs we leave the type attribute unexpanded because
6528 -- there's not a dispatching table to reference.
6530 if Tagged_Type_Expansion then
6532 Unchecked_Convert_To (RTE (RE_Tag),
6534 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6535 Analyze_And_Resolve (N, RTE (RE_Tag));
6538 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6539 -- references the primary tag of the actual object. If 'Tag is
6540 -- applied to class-wide interface objects we generate code that
6541 -- displaces "this" to reference the base of the object.
6543 elsif Comes_From_Source (N)
6544 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6545 and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
6548 -- (To_Tag_Ptr (Prefix'Address)).all
6550 -- Note that Prefix'Address is recursively expanded into a call
6551 -- to Base_Address (Obj.Tag)
6553 -- Not needed for VM targets, since all handled by the VM
6555 if Tagged_Type_Expansion then
6557 Make_Explicit_Dereference (Loc,
6558 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6559 Make_Attribute_Reference (Loc,
6560 Prefix => Relocate_Node (Pref),
6561 Attribute_Name => Name_Address))));
6562 Analyze_And_Resolve (N, RTE (RE_Tag));
6567 Make_Selected_Component (Loc,
6568 Prefix => Relocate_Node (Pref),
6570 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6571 Analyze_And_Resolve (N, RTE (RE_Tag));
6579 -- Transforms 'Terminated attribute into a call to Terminated function
6581 when Attribute_Terminated => Terminated : begin
6583 -- The prefix of Terminated is of a task interface class-wide type.
6585 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6587 if Ada_Version >= Ada_2005
6588 and then Ekind (Ptyp) = E_Class_Wide_Type
6589 and then Is_Interface (Ptyp)
6590 and then Is_Task_Interface (Ptyp)
6593 Make_Function_Call (Loc,
6595 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6596 Parameter_Associations => New_List (
6597 Make_Unchecked_Type_Conversion (Loc,
6599 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6600 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
6602 elsif Restricted_Profile then
6604 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6608 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6611 Analyze_And_Resolve (N, Standard_Boolean);
6618 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6619 -- unchecked conversion from (integral) type of X to type address. If
6620 -- the To_Address is a static expression, the transformed expression
6621 -- also needs to be static, because we do some legality checks (e.g.
6622 -- for Thread_Local_Storage) after this transformation.
6625 | Attribute_To_Address
6627 To_Address : declare
6628 Is_Static : constant Boolean := Is_Static_Expression (N);
6632 Unchecked_Convert_To (RTE (RE_Address),
6633 Relocate_Node (First (Exprs))));
6634 Set_Is_Static_Expression (N, Is_Static);
6636 Analyze_And_Resolve (N, RTE (RE_Address));
6643 when Attribute_To_Any => To_Any : declare
6644 P_Type : constant Entity_Id := Etype (Pref);
6645 Decls : constant List_Id := New_List;
6651 Relocate_Node (First (Exprs))), Decls));
6652 Insert_Actions (N, Decls);
6653 Analyze_And_Resolve (N, RTE (RE_Any));
6660 -- Transforms 'Truncation into a call to the floating-point attribute
6661 -- function Truncation in Fat_xxx (where xxx is the root type).
6662 -- Expansion is avoided for cases the back end can handle directly.
6664 when Attribute_Truncation =>
6665 if not Is_Inline_Floating_Point_Attribute (N) then
6666 Expand_Fpt_Attribute_R (N);
6673 when Attribute_TypeCode => TypeCode : declare
6674 P_Type : constant Entity_Id := Etype (Pref);
6675 Decls : constant List_Id := New_List;
6677 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6678 Insert_Actions (N, Decls);
6679 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6682 -----------------------
6683 -- Unbiased_Rounding --
6684 -----------------------
6686 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6687 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6688 -- root type). Expansion is avoided for cases the back end can handle
6691 when Attribute_Unbiased_Rounding =>
6692 if not Is_Inline_Floating_Point_Attribute (N) then
6693 Expand_Fpt_Attribute_R (N);
6700 when Attribute_Update =>
6701 Expand_Update_Attribute (N);
6707 -- The processing for VADS_Size is shared with Size
6713 -- For enumeration types with a standard representation, and for all
6714 -- other types, Val is handled by the back end. For enumeration types
6715 -- with a non-standard representation we use the _Pos_To_Rep array that
6716 -- was created when the type was frozen.
6718 when Attribute_Val => Val : declare
6719 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6722 if Is_Enumeration_Type (Etyp)
6723 and then Present (Enum_Pos_To_Rep (Etyp))
6725 if Has_Contiguous_Rep (Etyp) then
6727 Rep_Node : constant Node_Id :=
6728 Unchecked_Convert_To (Etyp,
6731 Make_Integer_Literal (Loc,
6732 Enumeration_Rep (First_Literal (Etyp))),
6734 (Convert_To (Standard_Integer,
6735 Relocate_Node (First (Exprs))))));
6739 Unchecked_Convert_To (Etyp,
6742 Make_Integer_Literal (Loc,
6743 Enumeration_Rep (First_Literal (Etyp))),
6745 Make_Function_Call (Loc,
6748 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6749 Parameter_Associations => New_List (
6751 Rep_To_Pos_Flag (Etyp, Loc))))));
6756 Make_Indexed_Component (Loc,
6757 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6758 Expressions => New_List (
6759 Convert_To (Standard_Integer,
6760 Relocate_Node (First (Exprs))))));
6763 Analyze_And_Resolve (N, Typ);
6765 -- If the argument is marked as requiring a range check then generate
6768 elsif Do_Range_Check (First (Exprs)) then
6769 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6777 -- The code for valid is dependent on the particular types involved.
6778 -- See separate sections below for the generated code in each case.
6780 when Attribute_Valid => Valid : declare
6781 Btyp : Entity_Id := Base_Type (Ptyp);
6783 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6784 -- Save the validity checking mode. We always turn off validity
6785 -- checking during process of 'Valid since this is one place
6786 -- where we do not want the implicit validity checks to interfere
6787 -- with the explicit validity check that the programmer is doing.
6789 function Make_Range_Test return Node_Id;
6790 -- Build the code for a range test of the form
6791 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6793 ---------------------
6794 -- Make_Range_Test --
6795 ---------------------
6797 function Make_Range_Test return Node_Id is
6801 -- The prefix of attribute 'Valid should always denote an object
6802 -- reference. The reference is either coming directly from source
6803 -- or is produced by validity check expansion. The object may be
6804 -- wrapped in a conversion in which case the call to Unqual_Conv
6807 -- If the prefix denotes a variable which captures the value of
6808 -- an object for validation purposes, use the variable in the
6809 -- range test. This ensures that no extra copies or extra reads
6810 -- are produced as part of the test. Generate:
6812 -- Temp : ... := Object;
6813 -- if not Temp in ... then
6815 if Is_Validation_Variable_Reference (Pref) then
6816 Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
6818 -- Otherwise the prefix is either a source object or a constant
6819 -- produced by validity check expansion. Generate:
6821 -- Temp : constant ... := Pref;
6822 -- if not Temp in ... then
6825 Temp := Duplicate_Subexpr (Pref);
6830 Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
6834 Unchecked_Convert_To (Btyp,
6835 Make_Attribute_Reference (Loc,
6836 Prefix => New_Occurrence_Of (Ptyp, Loc),
6837 Attribute_Name => Name_First)),
6839 Unchecked_Convert_To (Btyp,
6840 Make_Attribute_Reference (Loc,
6841 Prefix => New_Occurrence_Of (Ptyp, Loc),
6842 Attribute_Name => Name_Last))));
6843 end Make_Range_Test;
6849 -- Start of processing for Attribute_Valid
6852 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6853 -- will be handled by the back-end directly.
6855 if CodePeer_Mode and then Comes_From_Source (N) then
6859 -- Turn off validity checks. We do not want any implicit validity
6860 -- checks to intefere with the explicit check from the attribute
6862 Validity_Checks_On := False;
6864 -- Retrieve the base type. Handle the case where the base type is a
6865 -- private enumeration type.
6867 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6868 Btyp := Full_View (Btyp);
6871 -- Floating-point case. This case is handled by the Valid attribute
6872 -- code in the floating-point attribute run-time library.
6874 if Is_Floating_Point_Type (Ptyp) then
6875 Float_Valid : declare
6879 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6880 -- Return entity for Pkg.Nam
6882 --------------------
6883 -- Get_Fat_Entity --
6884 --------------------
6886 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6887 Exp_Name : constant Node_Id :=
6888 Make_Selected_Component (Loc,
6889 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6890 Selector_Name => Make_Identifier (Loc, Nam));
6892 Find_Selected_Component (Exp_Name);
6893 return Entity (Exp_Name);
6896 -- Start of processing for Float_Valid
6899 -- The C and AAMP back-ends handle Valid for fpt types
6901 if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
6902 Analyze_And_Resolve (Pref, Ptyp);
6903 Set_Etype (N, Standard_Boolean);
6907 Find_Fat_Info (Ptyp, Ftp, Pkg);
6909 -- If the prefix is a reverse SSO component, or is possibly
6910 -- unaligned, first create a temporary copy that is in
6911 -- native SSO, and properly aligned. Make it Volatile to
6912 -- prevent folding in the back-end. Note that we use an
6913 -- intermediate constrained string type to initialize the
6914 -- temporary, as the value at hand might be invalid, and in
6915 -- that case it cannot be copied using a floating point
6918 if In_Reverse_Storage_Order_Object (Pref)
6919 or else Is_Possibly_Unaligned_Object (Pref)
6922 Temp : constant Entity_Id :=
6923 Make_Temporary (Loc, 'F');
6925 Fat_S : constant Entity_Id :=
6926 Get_Fat_Entity (Name_S);
6927 -- Constrained string subtype of appropriate size
6929 Fat_P : constant Entity_Id :=
6930 Get_Fat_Entity (Name_P);
6933 Decl : constant Node_Id :=
6934 Make_Object_Declaration (Loc,
6935 Defining_Identifier => Temp,
6936 Aliased_Present => True,
6937 Object_Definition =>
6938 New_Occurrence_Of (Ptyp, Loc));
6941 Set_Aspect_Specifications (Decl, New_List (
6942 Make_Aspect_Specification (Loc,
6944 Make_Identifier (Loc, Name_Volatile))));
6950 Make_Assignment_Statement (Loc,
6952 Make_Explicit_Dereference (Loc,
6954 Unchecked_Convert_To (Fat_P,
6955 Make_Attribute_Reference (Loc,
6957 New_Occurrence_Of (Temp, Loc),
6959 Name_Unrestricted_Access))),
6961 Unchecked_Convert_To (Fat_S,
6962 Relocate_Node (Pref)))),
6964 Suppress => All_Checks);
6966 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6970 -- We now have an object of the proper endianness and
6971 -- alignment, and can construct a Valid attribute.
6973 -- We make sure the prefix of this valid attribute is
6974 -- marked as not coming from source, to avoid losing
6975 -- warnings from 'Valid looking like a possible update.
6977 Set_Comes_From_Source (Pref, False);
6979 Expand_Fpt_Attribute
6980 (N, Pkg, Name_Valid,
6982 Make_Attribute_Reference (Loc,
6983 Prefix => Unchecked_Convert_To (Ftp, Pref),
6984 Attribute_Name => Name_Unrestricted_Access)));
6987 -- One more task, we still need a range check. Required
6988 -- only if we have a constraint, since the Valid routine
6989 -- catches infinities properly (infinities are never valid).
6991 -- The way we do the range check is simply to create the
6992 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6994 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6997 Left_Opnd => Relocate_Node (N),
7000 Left_Opnd => Convert_To (Btyp, Pref),
7001 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
7005 -- Enumeration type with holes
7007 -- For enumeration types with holes, the Pos value constructed by
7008 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
7009 -- second argument of False returns minus one for an invalid value,
7010 -- and the non-negative pos value for a valid value, so the
7011 -- expansion of X'Valid is simply:
7013 -- type(X)'Pos (X) >= 0
7015 -- We can't quite generate it that way because of the requirement
7016 -- for the non-standard second argument of False in the resulting
7017 -- rep_to_pos call, so we have to explicitly create:
7019 -- _rep_to_pos (X, False) >= 0
7021 -- If we have an enumeration subtype, we also check that the
7022 -- value is in range:
7024 -- _rep_to_pos (X, False) >= 0
7026 -- (X >= type(X)'First and then type(X)'Last <= X)
7028 elsif Is_Enumeration_Type (Ptyp)
7029 and then Present (Enum_Pos_To_Rep (Btyp))
7034 Make_Function_Call (Loc,
7036 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
7037 Parameter_Associations => New_List (
7039 New_Occurrence_Of (Standard_False, Loc))),
7040 Right_Opnd => Make_Integer_Literal (Loc, 0));
7044 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
7046 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
7048 -- The call to Make_Range_Test will create declarations
7049 -- that need a proper insertion point, but Pref is now
7050 -- attached to a node with no ancestor. Attach to tree
7051 -- even if it is to be rewritten below.
7053 Set_Parent (Tst, Parent (N));
7057 Left_Opnd => Make_Range_Test,
7063 -- Fortran convention booleans
7065 -- For the very special case of Fortran convention booleans, the
7066 -- value is always valid, since it is an integer with the semantics
7067 -- that non-zero is true, and any value is permissible.
7069 elsif Is_Boolean_Type (Ptyp)
7070 and then Convention (Ptyp) = Convention_Fortran
7072 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
7074 -- For biased representations, we will be doing an unchecked
7075 -- conversion without unbiasing the result. That means that the range
7076 -- test has to take this into account, and the proper form of the
7079 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
7081 elsif Has_Biased_Representation (Ptyp) then
7082 Btyp := RTE (RE_Unsigned_32);
7086 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
7088 Unchecked_Convert_To (Btyp,
7089 Make_Attribute_Reference (Loc,
7090 Prefix => New_Occurrence_Of (Ptyp, Loc),
7091 Attribute_Name => Name_Range_Length))));
7093 -- For all other scalar types, what we want logically is a
7096 -- X in type(X)'First .. type(X)'Last
7098 -- But that's precisely what won't work because of possible
7099 -- unwanted optimization (and indeed the basic motivation for
7100 -- the Valid attribute is exactly that this test does not work).
7101 -- What will work is:
7103 -- Btyp!(X) >= Btyp!(type(X)'First)
7105 -- Btyp!(X) <= Btyp!(type(X)'Last)
7107 -- where Btyp is an integer type large enough to cover the full
7108 -- range of possible stored values (i.e. it is chosen on the basis
7109 -- of the size of the type, not the range of the values). We write
7110 -- this as two tests, rather than a range check, so that static
7111 -- evaluation will easily remove either or both of the checks if
7112 -- they can be -statically determined to be true (this happens
7113 -- when the type of X is static and the range extends to the full
7114 -- range of stored values).
7116 -- Unsigned types. Note: it is safe to consider only whether the
7117 -- subtype is unsigned, since we will in that case be doing all
7118 -- unsigned comparisons based on the subtype range. Since we use the
7119 -- actual subtype object size, this is appropriate.
7121 -- For example, if we have
7123 -- subtype x is integer range 1 .. 200;
7124 -- for x'Object_Size use 8;
7126 -- Now the base type is signed, but objects of this type are bits
7127 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7128 -- correct, even though a value greater than 127 looks signed to a
7129 -- signed comparison.
7131 elsif Is_Unsigned_Type (Ptyp) then
7132 if Esize (Ptyp) <= 32 then
7133 Btyp := RTE (RE_Unsigned_32);
7135 Btyp := RTE (RE_Unsigned_64);
7138 Rewrite (N, Make_Range_Test);
7143 if Esize (Ptyp) <= Esize (Standard_Integer) then
7144 Btyp := Standard_Integer;
7146 Btyp := Universal_Integer;
7149 Rewrite (N, Make_Range_Test);
7152 -- If a predicate is present, then we do the predicate test, even if
7153 -- within the predicate function (infinite recursion is warned about
7154 -- in Sem_Attr in that case).
7157 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
7160 if Present (Pred_Func) then
7163 Left_Opnd => Relocate_Node (N),
7164 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
7168 Analyze_And_Resolve (N, Standard_Boolean);
7169 Validity_Checks_On := Save_Validity_Checks_On;
7176 when Attribute_Valid_Scalars => Valid_Scalars : declare
7177 Val_Typ : constant Entity_Id := Validated_View (Ptyp);
7178 Comp_Typ : Entity_Id;
7182 -- Assume that the prefix does not need validation
7186 -- Attribute 'Valid_Scalars is not supported on private tagged types
7188 if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
7191 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7194 elsif not Scalar_Part_Present (Val_Typ) then
7197 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7198 -- validated type is a scalar type. Generate:
7200 -- Val_Typ (Pref)'Valid
7202 elsif Is_Scalar_Type (Val_Typ) then
7204 Make_Attribute_Reference (Loc,
7206 Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
7207 Attribute_Name => Name_Valid);
7209 -- Validate the scalar components of an array by iterating over all
7210 -- dimensions of the array while checking individual components.
7212 elsif Is_Array_Type (Val_Typ) then
7213 Comp_Typ := Validated_View (Component_Type (Val_Typ));
7215 if Scalar_Part_Present (Comp_Typ) then
7217 Make_Function_Call (Loc,
7220 (Build_Array_VS_Func
7223 Array_Typ => Val_Typ,
7224 Comp_Typ => Comp_Typ),
7226 Parameter_Associations => New_List (Pref));
7229 -- Validate the scalar components, discriminants of a record type by
7230 -- examining the structure of a record type.
7232 elsif Is_Record_Type (Val_Typ) then
7234 Make_Function_Call (Loc,
7237 (Build_Record_VS_Func
7240 Rec_Typ => Val_Typ),
7242 Parameter_Associations => New_List (Pref));
7245 -- Default the attribute to True when the type of the prefix does not
7249 Expr := New_Occurrence_Of (Standard_True, Loc);
7253 Analyze_And_Resolve (N, Standard_Boolean);
7254 Set_Is_Static_Expression (N, False);
7261 -- Value attribute is handled in separate unit Exp_Imgv
7263 when Attribute_Value =>
7264 Exp_Imgv.Expand_Value_Attribute (N);
7270 -- The processing for Value_Size shares the processing for Size
7276 -- The processing for Version shares the processing for Body_Version
7282 -- Wide_Image attribute is handled in separate unit Exp_Imgv
7284 when Attribute_Wide_Image =>
7285 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7286 -- back-end knows how to handle this attribute directly.
7288 if CodePeer_Mode then
7292 Exp_Imgv.Expand_Wide_Image_Attribute (N);
7294 ---------------------
7295 -- Wide_Wide_Image --
7296 ---------------------
7298 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7300 when Attribute_Wide_Wide_Image =>
7301 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7302 -- back-end knows how to handle this attribute directly.
7304 if CodePeer_Mode then
7308 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
7314 -- We expand typ'Wide_Value (X) into
7317 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7319 -- Wide_String_To_String is a runtime function that converts its wide
7320 -- string argument to String, converting any non-translatable characters
7321 -- into appropriate escape sequences. This preserves the required
7322 -- semantics of Wide_Value in all cases, and results in a very simple
7323 -- implementation approach.
7325 -- Note: for this approach to be fully standard compliant for the cases
7326 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7327 -- method must cover the entire character range (e.g. UTF-8). But that
7328 -- is a reasonable requirement when dealing with encoded character
7329 -- sequences. Presumably if one of the restrictive encoding mechanisms
7330 -- is in use such as Shift-JIS, then characters that cannot be
7331 -- represented using this encoding will not appear in any case.
7333 when Attribute_Wide_Value =>
7335 Make_Attribute_Reference (Loc,
7337 Attribute_Name => Name_Value,
7339 Expressions => New_List (
7340 Make_Function_Call (Loc,
7342 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
7344 Parameter_Associations => New_List (
7345 Relocate_Node (First (Exprs)),
7346 Make_Integer_Literal (Loc,
7347 Intval => Int (Wide_Character_Encoding_Method)))))));
7349 Analyze_And_Resolve (N, Typ);
7351 ---------------------
7352 -- Wide_Wide_Value --
7353 ---------------------
7355 -- We expand typ'Wide_Value_Value (X) into
7358 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7360 -- Wide_Wide_String_To_String is a runtime function that converts its
7361 -- wide string argument to String, converting any non-translatable
7362 -- characters into appropriate escape sequences. This preserves the
7363 -- required semantics of Wide_Wide_Value in all cases, and results in a
7364 -- very simple implementation approach.
7366 -- It's not quite right where typ = Wide_Wide_Character, because the
7367 -- encoding method may not cover the whole character type ???
7369 when Attribute_Wide_Wide_Value =>
7371 Make_Attribute_Reference (Loc,
7373 Attribute_Name => Name_Value,
7375 Expressions => New_List (
7376 Make_Function_Call (Loc,
7379 (RTE (RE_Wide_Wide_String_To_String), Loc),
7381 Parameter_Associations => New_List (
7382 Relocate_Node (First (Exprs)),
7383 Make_Integer_Literal (Loc,
7384 Intval => Int (Wide_Character_Encoding_Method)))))));
7386 Analyze_And_Resolve (N, Typ);
7388 ---------------------
7389 -- Wide_Wide_Width --
7390 ---------------------
7392 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7394 when Attribute_Wide_Wide_Width =>
7395 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
7401 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7403 when Attribute_Wide_Width =>
7404 Exp_Imgv.Expand_Width_Attribute (N, Wide);
7410 -- Width attribute is handled in separate unit Exp_Imgv
7412 when Attribute_Width =>
7413 Exp_Imgv.Expand_Width_Attribute (N, Normal);
7419 when Attribute_Write => Write : declare
7420 P_Type : constant Entity_Id := Entity (Pref);
7421 U_Type : constant Entity_Id := Underlying_Type (P_Type);
7429 -- If no underlying type, we have an error that will be diagnosed
7430 -- elsewhere, so here we just completely ignore the expansion.
7436 -- Stream operations can appear in user code even if the restriction
7437 -- No_Streams is active (for example, when instantiating a predefined
7438 -- container). In that case rewrite the attribute as a Raise to
7439 -- prevent any run-time use.
7441 if Restriction_Active (No_Streams) then
7443 Make_Raise_Program_Error (Sloc (N),
7444 Reason => PE_Stream_Operation_Not_Allowed));
7445 Set_Etype (N, U_Type);
7449 -- The simple case, if there is a TSS for Write, just call it
7451 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
7453 if Present (Pname) then
7457 -- If there is a Stream_Convert pragma, use it, we rewrite
7459 -- sourcetyp'Output (stream, Item)
7463 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7465 -- where strmwrite is the given Write function that converts an
7466 -- argument of type sourcetyp or a type acctyp, from which it is
7467 -- derived to type strmtyp. The conversion to acttyp is required
7468 -- for the derived case.
7470 Prag := Get_Stream_Convert_Pragma (P_Type);
7472 if Present (Prag) then
7474 Next (Next (First (Pragma_Argument_Associations (Prag))));
7475 Wfunc := Entity (Expression (Arg3));
7478 Make_Attribute_Reference (Loc,
7479 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
7480 Attribute_Name => Name_Output,
7481 Expressions => New_List (
7482 Relocate_Node (First (Exprs)),
7483 Make_Function_Call (Loc,
7484 Name => New_Occurrence_Of (Wfunc, Loc),
7485 Parameter_Associations => New_List (
7486 OK_Convert_To (Etype (First_Formal (Wfunc)),
7487 Relocate_Node (Next (First (Exprs)))))))));
7492 -- For elementary types, we call the W_xxx routine directly
7494 elsif Is_Elementary_Type (U_Type) then
7495 Rewrite (N, Build_Elementary_Write_Call (N));
7501 elsif Is_Array_Type (U_Type) then
7502 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7503 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7505 -- Tagged type case, use the primitive Write function. Note that
7506 -- this will dispatch in the class-wide case which is what we want
7508 elsif Is_Tagged_Type (U_Type) then
7509 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
7511 -- All other record type cases, including protected records.
7512 -- The latter only arise for expander generated code for
7513 -- handling shared passive partition access.
7517 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7519 -- Ada 2005 (AI-216): Program_Error is raised when executing
7520 -- the default implementation of the Write attribute of an
7521 -- Unchecked_Union type. However, if the 'Write reference is
7522 -- within the generated Output stream procedure, Write outputs
7523 -- the components, and the default values of the discriminant
7524 -- are streamed by the Output procedure itself. If there are
7525 -- no default values this is also erroneous.
7527 if Is_Unchecked_Union (Base_Type (U_Type)) then
7528 if (not Is_TSS (Current_Scope, TSS_Stream_Output)
7529 and not Is_TSS (Current_Scope, TSS_Stream_Write))
7530 or else No (Discriminant_Default_Value
7531 (First_Discriminant (U_Type)))
7534 Make_Raise_Program_Error (Loc,
7535 Reason => PE_Unchecked_Union_Restriction));
7536 Set_Etype (N, U_Type);
7541 if Has_Discriminants (U_Type)
7543 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7545 Build_Mutable_Record_Write_Procedure
7546 (Loc, Full_Base (U_Type), Decl, Pname);
7548 Build_Record_Write_Procedure
7549 (Loc, Full_Base (U_Type), Decl, Pname);
7552 Insert_Action (N, Decl);
7556 -- If we fall through, Pname is the procedure to be called
7558 Rewrite_Stream_Proc_Call (Pname);
7561 -- Component_Size is handled by the back end, unless the component size
7562 -- is known at compile time, which is always true in the packed array
7563 -- case. It is important that the packed array case is handled in the
7564 -- front end (see Eval_Attribute) since the back end would otherwise get
7565 -- confused by the equivalent packed array type.
7567 when Attribute_Component_Size =>
7570 -- The following attributes are handled by the back end (except that
7571 -- static cases have already been evaluated during semantic processing,
7572 -- but in any case the back end should not count on this).
7574 -- The back end also handles the non-class-wide cases of Size
7576 when Attribute_Bit_Order
7577 | Attribute_Code_Address
7578 | Attribute_Definite
7580 | Attribute_Null_Parameter
7581 | Attribute_Passed_By_Reference
7582 | Attribute_Pool_Address
7583 | Attribute_Scalar_Storage_Order
7587 -- The following attributes are also handled by the back end, but return
7588 -- a universal integer result, so may need a conversion for checking
7589 -- that the result is in range.
7592 | Attribute_Max_Alignment_For_Allocation
7594 Apply_Universal_Integer_Attribute_Checks (N);
7596 -- The following attributes should not appear at this stage, since they
7597 -- have already been handled by the analyzer (and properly rewritten
7598 -- with corresponding values or entities to represent the right values)
7600 when Attribute_Abort_Signal
7601 | Attribute_Address_Size
7602 | Attribute_Atomic_Always_Lock_Free
7605 | Attribute_Compiler_Version
7606 | Attribute_Default_Bit_Order
7607 | Attribute_Default_Scalar_Storage_Order
7614 | Attribute_Fast_Math
7615 | Attribute_First_Valid
7616 | Attribute_Has_Access_Values
7617 | Attribute_Has_Discriminants
7618 | Attribute_Has_Tagged_Values
7620 | Attribute_Last_Valid
7621 | Attribute_Library_Level
7622 | Attribute_Lock_Free
7623 | Attribute_Machine_Emax
7624 | Attribute_Machine_Emin
7625 | Attribute_Machine_Mantissa
7626 | Attribute_Machine_Overflows
7627 | Attribute_Machine_Radix
7628 | Attribute_Machine_Rounds
7629 | Attribute_Maximum_Alignment
7630 | Attribute_Model_Emin
7631 | Attribute_Model_Epsilon
7632 | Attribute_Model_Mantissa
7633 | Attribute_Model_Small
7635 | Attribute_Partition_ID
7637 | Attribute_Restriction_Set
7638 | Attribute_Safe_Emax
7639 | Attribute_Safe_First
7640 | Attribute_Safe_Large
7641 | Attribute_Safe_Last
7642 | Attribute_Safe_Small
7644 | Attribute_Signed_Zeros
7646 | Attribute_Storage_Unit
7647 | Attribute_Stub_Type
7648 | Attribute_System_Allocator_Alignment
7649 | Attribute_Target_Name
7650 | Attribute_Type_Class
7651 | Attribute_Type_Key
7652 | Attribute_Unconstrained_Array
7653 | Attribute_Universal_Literal_String
7654 | Attribute_Wchar_T_Size
7655 | Attribute_Word_Size
7657 raise Program_Error;
7659 -- The Asm_Input and Asm_Output attributes are not expanded at this
7660 -- stage, but will be eliminated in the expansion of the Asm call, see
7661 -- Exp_Intr for details. So the back end will never see these either.
7663 when Attribute_Asm_Input
7664 | Attribute_Asm_Output
7669 -- Note: as mentioned earlier, individual sections of the above case
7670 -- statement assume there is no code after the case statement, and are
7671 -- legitimately allowed to execute return statements if they have nothing
7672 -- more to do, so DO NOT add code at this point.
7675 when RE_Not_Available =>
7677 end Expand_N_Attribute_Reference;
7679 --------------------------------
7680 -- Expand_Pred_Succ_Attribute --
7681 --------------------------------
7683 -- For typ'Pred (exp), we generate the check
7685 -- [constraint_error when exp = typ'Base'First]
7687 -- Similarly, for typ'Succ (exp), we generate the check
7689 -- [constraint_error when exp = typ'Base'Last]
7691 -- These checks are not generated for modular types, since the proper
7692 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7693 -- We also suppress these checks if we are the right side of an assignment
7694 -- statement or the expression of an object declaration, where the flag
7695 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7697 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7698 Loc : constant Source_Ptr := Sloc (N);
7699 P : constant Node_Id := Parent (N);
7703 if Attribute_Name (N) = Name_Pred then
7709 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7710 or else not Suppress_Assignment_Checks (P)
7713 Make_Raise_Constraint_Error (Loc,
7717 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7719 Make_Attribute_Reference (Loc,
7721 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7722 Attribute_Name => Cnam)),
7723 Reason => CE_Overflow_Check_Failed));
7725 end Expand_Pred_Succ_Attribute;
7727 -----------------------------
7728 -- Expand_Update_Attribute --
7729 -----------------------------
7731 procedure Expand_Update_Attribute (N : Node_Id) is
7732 procedure Process_Component_Or_Element_Update
7737 -- Generate the statements necessary to update a single component or an
7738 -- element of the prefix. The code is inserted before the attribute N.
7739 -- Temp denotes the entity of the anonymous object created to reflect
7740 -- the changes in values. Comp is the component/index expression to be
7741 -- updated. Expr is an expression yielding the new value of Comp. Typ
7742 -- is the type of the prefix of attribute Update.
7744 procedure Process_Range_Update
7749 -- Generate the statements necessary to update a slice of the prefix.
7750 -- The code is inserted before the attribute N. Temp denotes the entity
7751 -- of the anonymous object created to reflect the changes in values.
7752 -- Comp is range of the slice to be updated. Expr is an expression
7753 -- yielding the new value of Comp. Typ is the type of the prefix of
7754 -- attribute Update.
7756 -----------------------------------------
7757 -- Process_Component_Or_Element_Update --
7758 -----------------------------------------
7760 procedure Process_Component_Or_Element_Update
7766 Loc : constant Source_Ptr := Sloc (Comp);
7771 -- An array element may be modified by the following relations
7772 -- depending on the number of dimensions:
7774 -- 1 => Expr -- one dimensional update
7775 -- (1, ..., N) => Expr -- multi dimensional update
7777 -- The above forms are converted in assignment statements where the
7778 -- left hand side is an indexed component:
7780 -- Temp (1) := Expr; -- one dimensional update
7781 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7783 if Is_Array_Type (Typ) then
7785 -- The index expressions of a multi dimensional array update
7786 -- appear as an aggregate.
7788 if Nkind (Comp) = N_Aggregate then
7789 Exprs := New_Copy_List_Tree (Expressions (Comp));
7791 Exprs := New_List (Relocate_Node (Comp));
7795 Make_Indexed_Component (Loc,
7796 Prefix => New_Occurrence_Of (Temp, Loc),
7797 Expressions => Exprs);
7799 -- A record component update appears in the following form:
7803 -- The above relation is transformed into an assignment statement
7804 -- where the left hand side is a selected component:
7806 -- Temp.Comp := Expr;
7808 else pragma Assert (Is_Record_Type (Typ));
7810 Make_Selected_Component (Loc,
7811 Prefix => New_Occurrence_Of (Temp, Loc),
7812 Selector_Name => Relocate_Node (Comp));
7816 Make_Assignment_Statement (Loc,
7818 Expression => Relocate_Node (Expr)));
7819 end Process_Component_Or_Element_Update;
7821 --------------------------
7822 -- Process_Range_Update --
7823 --------------------------
7825 procedure Process_Range_Update
7831 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7832 Loc : constant Source_Ptr := Sloc (Comp);
7836 -- A range update appears as
7838 -- (Low .. High => Expr)
7840 -- The above construct is transformed into a loop that iterates over
7841 -- the given range and modifies the corresponding array values to the
7844 -- for Index in Low .. High loop
7845 -- Temp (<Index_Typ> (Index)) := Expr;
7848 Index := Make_Temporary (Loc, 'I');
7851 Make_Loop_Statement (Loc,
7853 Make_Iteration_Scheme (Loc,
7854 Loop_Parameter_Specification =>
7855 Make_Loop_Parameter_Specification (Loc,
7856 Defining_Identifier => Index,
7857 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7859 Statements => New_List (
7860 Make_Assignment_Statement (Loc,
7862 Make_Indexed_Component (Loc,
7863 Prefix => New_Occurrence_Of (Temp, Loc),
7864 Expressions => New_List (
7865 Convert_To (Index_Typ,
7866 New_Occurrence_Of (Index, Loc)))),
7867 Expression => Relocate_Node (Expr))),
7869 End_Label => Empty));
7870 end Process_Range_Update;
7874 Aggr : constant Node_Id := First (Expressions (N));
7875 Loc : constant Source_Ptr := Sloc (N);
7876 Pref : constant Node_Id := Prefix (N);
7877 Typ : constant Entity_Id := Etype (Pref);
7880 CW_Temp : Entity_Id;
7885 -- Start of processing for Expand_Update_Attribute
7888 -- Create the anonymous object to store the value of the prefix and
7889 -- capture subsequent changes in value.
7891 Temp := Make_Temporary (Loc, 'T', Pref);
7893 -- Preserve the tag of the prefix by offering a specific view of the
7894 -- class-wide version of the prefix.
7896 if Is_Tagged_Type (Typ) then
7899 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7901 CW_Temp := Make_Temporary (Loc, 'T');
7902 CW_Typ := Class_Wide_Type (Typ);
7905 Make_Object_Declaration (Loc,
7906 Defining_Identifier => CW_Temp,
7907 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7909 Convert_To (CW_Typ, Relocate_Node (Pref))));
7912 -- Temp : Typ renames Typ (CW_Temp);
7915 Make_Object_Renaming_Declaration (Loc,
7916 Defining_Identifier => Temp,
7917 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7919 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7925 -- Temp : Typ := Pref;
7928 Make_Object_Declaration (Loc,
7929 Defining_Identifier => Temp,
7930 Object_Definition => New_Occurrence_Of (Typ, Loc),
7931 Expression => Relocate_Node (Pref)));
7934 -- Process the update aggregate
7936 Assoc := First (Component_Associations (Aggr));
7937 while Present (Assoc) loop
7938 Comp := First (Choices (Assoc));
7939 Expr := Expression (Assoc);
7940 while Present (Comp) loop
7941 if Nkind (Comp) = N_Range then
7942 Process_Range_Update (Temp, Comp, Expr, Typ);
7944 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7953 -- The attribute is replaced by a reference to the anonymous object
7955 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7957 end Expand_Update_Attribute;
7963 procedure Find_Fat_Info
7965 Fat_Type : out Entity_Id;
7966 Fat_Pkg : out RE_Id)
7968 Rtyp : constant Entity_Id := Root_Type (T);
7971 -- All we do is use the root type (historically this dealt with
7972 -- VAX-float .. to be cleaned up further later ???)
7976 if Fat_Type = Standard_Short_Float then
7977 Fat_Pkg := RE_Attr_Short_Float;
7979 elsif Fat_Type = Standard_Float then
7980 Fat_Pkg := RE_Attr_Float;
7982 elsif Fat_Type = Standard_Long_Float then
7983 Fat_Pkg := RE_Attr_Long_Float;
7985 elsif Fat_Type = Standard_Long_Long_Float then
7986 Fat_Pkg := RE_Attr_Long_Long_Float;
7988 -- Universal real (which is its own root type) is treated as being
7989 -- equivalent to Standard.Long_Long_Float, since it is defined to
7990 -- have the same precision as the longest Float type.
7992 elsif Fat_Type = Universal_Real then
7993 Fat_Type := Standard_Long_Long_Float;
7994 Fat_Pkg := RE_Attr_Long_Long_Float;
7997 raise Program_Error;
8001 ----------------------------
8002 -- Find_Stream_Subprogram --
8003 ----------------------------
8005 function Find_Stream_Subprogram
8007 Nam : TSS_Name_Type) return Entity_Id
8009 Base_Typ : constant Entity_Id := Base_Type (Typ);
8010 Ent : constant Entity_Id := TSS (Typ, Nam);
8012 function Is_Available (Entity : RE_Id) return Boolean;
8013 pragma Inline (Is_Available);
8014 -- Function to check whether the specified run-time call is available
8015 -- in the run time used. In the case of a configurable run time, it
8016 -- is normal that some subprograms are not there.
8018 -- I don't understand this routine at all, why is this not just a
8019 -- call to RTE_Available? And if for some reason we need a different
8020 -- routine with different semantics, why is not in Rtsfind ???
8026 function Is_Available (Entity : RE_Id) return Boolean is
8028 -- Assume that the unit will always be available when using a
8029 -- "normal" (not configurable) run time.
8031 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
8034 -- Start of processing for Find_Stream_Subprogram
8037 if Present (Ent) then
8041 -- Stream attributes for strings are expanded into library calls. The
8042 -- following checks are disabled when the run-time is not available or
8043 -- when compiling predefined types due to bootstrap issues. As a result,
8044 -- the compiler will generate in-place stream routines for string types
8045 -- that appear in GNAT's library, but will generate calls via rtsfind
8046 -- to library routines for user code.
8048 -- Note: In the case of using a configurable run time, it is very likely
8049 -- that stream routines for string types are not present (they require
8050 -- file system support). In this case, the specific stream routines for
8051 -- strings are not used, relying on the regular stream mechanism
8052 -- instead. That is why we include the test Is_Available when dealing
8053 -- with these cases.
8055 if not Is_Predefined_Unit (Current_Sem_Unit) then
8056 -- Storage_Array as defined in package System.Storage_Elements
8058 if Is_RTE (Base_Typ, RE_Storage_Array) then
8060 -- Case of No_Stream_Optimizations restriction active
8062 if Restriction_Active (No_Stream_Optimizations) then
8063 if Nam = TSS_Stream_Input
8064 and then Is_Available (RE_Storage_Array_Input)
8066 return RTE (RE_Storage_Array_Input);
8068 elsif Nam = TSS_Stream_Output
8069 and then Is_Available (RE_Storage_Array_Output)
8071 return RTE (RE_Storage_Array_Output);
8073 elsif Nam = TSS_Stream_Read
8074 and then Is_Available (RE_Storage_Array_Read)
8076 return RTE (RE_Storage_Array_Read);
8078 elsif Nam = TSS_Stream_Write
8079 and then Is_Available (RE_Storage_Array_Write)
8081 return RTE (RE_Storage_Array_Write);
8083 elsif Nam /= TSS_Stream_Input and then
8084 Nam /= TSS_Stream_Output and then
8085 Nam /= TSS_Stream_Read and then
8086 Nam /= TSS_Stream_Write
8088 raise Program_Error;
8091 -- Restriction No_Stream_Optimizations is not set, so we can go
8092 -- ahead and optimize using the block IO forms of the routines.
8095 if Nam = TSS_Stream_Input
8096 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
8098 return RTE (RE_Storage_Array_Input_Blk_IO);
8100 elsif Nam = TSS_Stream_Output
8101 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
8103 return RTE (RE_Storage_Array_Output_Blk_IO);
8105 elsif Nam = TSS_Stream_Read
8106 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
8108 return RTE (RE_Storage_Array_Read_Blk_IO);
8110 elsif Nam = TSS_Stream_Write
8111 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
8113 return RTE (RE_Storage_Array_Write_Blk_IO);
8115 elsif Nam /= TSS_Stream_Input and then
8116 Nam /= TSS_Stream_Output and then
8117 Nam /= TSS_Stream_Read and then
8118 Nam /= TSS_Stream_Write
8120 raise Program_Error;
8124 -- Stream_Element_Array as defined in package Ada.Streams
8126 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
8128 -- Case of No_Stream_Optimizations restriction active
8130 if Restriction_Active (No_Stream_Optimizations) then
8131 if Nam = TSS_Stream_Input
8132 and then Is_Available (RE_Stream_Element_Array_Input)
8134 return RTE (RE_Stream_Element_Array_Input);
8136 elsif Nam = TSS_Stream_Output
8137 and then Is_Available (RE_Stream_Element_Array_Output)
8139 return RTE (RE_Stream_Element_Array_Output);
8141 elsif Nam = TSS_Stream_Read
8142 and then Is_Available (RE_Stream_Element_Array_Read)
8144 return RTE (RE_Stream_Element_Array_Read);
8146 elsif Nam = TSS_Stream_Write
8147 and then Is_Available (RE_Stream_Element_Array_Write)
8149 return RTE (RE_Stream_Element_Array_Write);
8151 elsif Nam /= TSS_Stream_Input and then
8152 Nam /= TSS_Stream_Output and then
8153 Nam /= TSS_Stream_Read and then
8154 Nam /= TSS_Stream_Write
8156 raise Program_Error;
8159 -- Restriction No_Stream_Optimizations is not set, so we can go
8160 -- ahead and optimize using the block IO forms of the routines.
8163 if Nam = TSS_Stream_Input
8164 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
8166 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
8168 elsif Nam = TSS_Stream_Output
8169 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
8171 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
8173 elsif Nam = TSS_Stream_Read
8174 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
8176 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
8178 elsif Nam = TSS_Stream_Write
8179 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
8181 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
8183 elsif Nam /= TSS_Stream_Input and then
8184 Nam /= TSS_Stream_Output and then
8185 Nam /= TSS_Stream_Read and then
8186 Nam /= TSS_Stream_Write
8188 raise Program_Error;
8192 -- String as defined in package Ada
8194 elsif Base_Typ = Standard_String then
8196 -- Case of No_Stream_Optimizations restriction active
8198 if Restriction_Active (No_Stream_Optimizations) then
8199 if Nam = TSS_Stream_Input
8200 and then Is_Available (RE_String_Input)
8202 return RTE (RE_String_Input);
8204 elsif Nam = TSS_Stream_Output
8205 and then Is_Available (RE_String_Output)
8207 return RTE (RE_String_Output);
8209 elsif Nam = TSS_Stream_Read
8210 and then Is_Available (RE_String_Read)
8212 return RTE (RE_String_Read);
8214 elsif Nam = TSS_Stream_Write
8215 and then Is_Available (RE_String_Write)
8217 return RTE (RE_String_Write);
8219 elsif Nam /= TSS_Stream_Input and then
8220 Nam /= TSS_Stream_Output and then
8221 Nam /= TSS_Stream_Read and then
8222 Nam /= TSS_Stream_Write
8224 raise Program_Error;
8227 -- Restriction No_Stream_Optimizations is not set, so we can go
8228 -- ahead and optimize using the block IO forms of the routines.
8231 if Nam = TSS_Stream_Input
8232 and then Is_Available (RE_String_Input_Blk_IO)
8234 return RTE (RE_String_Input_Blk_IO);
8236 elsif Nam = TSS_Stream_Output
8237 and then Is_Available (RE_String_Output_Blk_IO)
8239 return RTE (RE_String_Output_Blk_IO);
8241 elsif Nam = TSS_Stream_Read
8242 and then Is_Available (RE_String_Read_Blk_IO)
8244 return RTE (RE_String_Read_Blk_IO);
8246 elsif Nam = TSS_Stream_Write
8247 and then Is_Available (RE_String_Write_Blk_IO)
8249 return RTE (RE_String_Write_Blk_IO);
8251 elsif Nam /= TSS_Stream_Input and then
8252 Nam /= TSS_Stream_Output and then
8253 Nam /= TSS_Stream_Read and then
8254 Nam /= TSS_Stream_Write
8256 raise Program_Error;
8260 -- Wide_String as defined in package Ada
8262 elsif Base_Typ = Standard_Wide_String then
8264 -- Case of No_Stream_Optimizations restriction active
8266 if Restriction_Active (No_Stream_Optimizations) then
8267 if Nam = TSS_Stream_Input
8268 and then Is_Available (RE_Wide_String_Input)
8270 return RTE (RE_Wide_String_Input);
8272 elsif Nam = TSS_Stream_Output
8273 and then Is_Available (RE_Wide_String_Output)
8275 return RTE (RE_Wide_String_Output);
8277 elsif Nam = TSS_Stream_Read
8278 and then Is_Available (RE_Wide_String_Read)
8280 return RTE (RE_Wide_String_Read);
8282 elsif Nam = TSS_Stream_Write
8283 and then Is_Available (RE_Wide_String_Write)
8285 return RTE (RE_Wide_String_Write);
8287 elsif Nam /= TSS_Stream_Input and then
8288 Nam /= TSS_Stream_Output and then
8289 Nam /= TSS_Stream_Read and then
8290 Nam /= TSS_Stream_Write
8292 raise Program_Error;
8295 -- Restriction No_Stream_Optimizations is not set, so we can go
8296 -- ahead and optimize using the block IO forms of the routines.
8299 if Nam = TSS_Stream_Input
8300 and then Is_Available (RE_Wide_String_Input_Blk_IO)
8302 return RTE (RE_Wide_String_Input_Blk_IO);
8304 elsif Nam = TSS_Stream_Output
8305 and then Is_Available (RE_Wide_String_Output_Blk_IO)
8307 return RTE (RE_Wide_String_Output_Blk_IO);
8309 elsif Nam = TSS_Stream_Read
8310 and then Is_Available (RE_Wide_String_Read_Blk_IO)
8312 return RTE (RE_Wide_String_Read_Blk_IO);
8314 elsif Nam = TSS_Stream_Write
8315 and then Is_Available (RE_Wide_String_Write_Blk_IO)
8317 return RTE (RE_Wide_String_Write_Blk_IO);
8319 elsif Nam /= TSS_Stream_Input and then
8320 Nam /= TSS_Stream_Output and then
8321 Nam /= TSS_Stream_Read and then
8322 Nam /= TSS_Stream_Write
8324 raise Program_Error;
8328 -- Wide_Wide_String as defined in package Ada
8330 elsif Base_Typ = Standard_Wide_Wide_String then
8332 -- Case of No_Stream_Optimizations restriction active
8334 if Restriction_Active (No_Stream_Optimizations) then
8335 if Nam = TSS_Stream_Input
8336 and then Is_Available (RE_Wide_Wide_String_Input)
8338 return RTE (RE_Wide_Wide_String_Input);
8340 elsif Nam = TSS_Stream_Output
8341 and then Is_Available (RE_Wide_Wide_String_Output)
8343 return RTE (RE_Wide_Wide_String_Output);
8345 elsif Nam = TSS_Stream_Read
8346 and then Is_Available (RE_Wide_Wide_String_Read)
8348 return RTE (RE_Wide_Wide_String_Read);
8350 elsif Nam = TSS_Stream_Write
8351 and then Is_Available (RE_Wide_Wide_String_Write)
8353 return RTE (RE_Wide_Wide_String_Write);
8355 elsif Nam /= TSS_Stream_Input and then
8356 Nam /= TSS_Stream_Output and then
8357 Nam /= TSS_Stream_Read and then
8358 Nam /= TSS_Stream_Write
8360 raise Program_Error;
8363 -- Restriction No_Stream_Optimizations is not set, so we can go
8364 -- ahead and optimize using the block IO forms of the routines.
8367 if Nam = TSS_Stream_Input
8368 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
8370 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
8372 elsif Nam = TSS_Stream_Output
8373 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
8375 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
8377 elsif Nam = TSS_Stream_Read
8378 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
8380 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
8382 elsif Nam = TSS_Stream_Write
8383 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
8385 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
8387 elsif Nam /= TSS_Stream_Input and then
8388 Nam /= TSS_Stream_Output and then
8389 Nam /= TSS_Stream_Read and then
8390 Nam /= TSS_Stream_Write
8392 raise Program_Error;
8398 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8399 return Find_Prim_Op (Typ, Nam);
8401 return Find_Inherited_TSS (Typ, Nam);
8403 end Find_Stream_Subprogram;
8409 function Full_Base (T : Entity_Id) return Entity_Id is
8413 BT := Base_Type (T);
8415 if Is_Private_Type (BT)
8416 and then Present (Full_View (BT))
8418 BT := Full_View (BT);
8424 -----------------------
8425 -- Get_Index_Subtype --
8426 -----------------------
8428 function Get_Index_Subtype (N : Node_Id) return Node_Id is
8429 P_Type : Entity_Id := Etype (Prefix (N));
8434 if Is_Access_Type (P_Type) then
8435 P_Type := Designated_Type (P_Type);
8438 if No (Expressions (N)) then
8441 J := UI_To_Int (Expr_Value (First (Expressions (N))));
8444 Indx := First_Index (P_Type);
8450 return Etype (Indx);
8451 end Get_Index_Subtype;
8453 -------------------------------
8454 -- Get_Stream_Convert_Pragma --
8455 -------------------------------
8457 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
8462 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8463 -- that a stream convert pragma for a tagged type is not inherited from
8464 -- its parent. Probably what is wrong here is that it is basically
8465 -- incorrect to consider a stream convert pragma to be a representation
8466 -- pragma at all ???
8468 N := First_Rep_Item (Implementation_Base_Type (T));
8469 while Present (N) loop
8470 if Nkind (N) = N_Pragma
8471 and then Pragma_Name (N) = Name_Stream_Convert
8473 -- For tagged types this pragma is not inherited, so we
8474 -- must verify that it is defined for the given type and
8478 Entity (Expression (First (Pragma_Argument_Associations (N))));
8480 if not Is_Tagged_Type (T)
8482 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
8492 end Get_Stream_Convert_Pragma;
8494 ---------------------------------
8495 -- Is_Constrained_Packed_Array --
8496 ---------------------------------
8498 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8499 Arr : Entity_Id := Typ;
8502 if Is_Access_Type (Arr) then
8503 Arr := Designated_Type (Arr);
8506 return Is_Array_Type (Arr)
8507 and then Is_Constrained (Arr)
8508 and then Present (Packed_Array_Impl_Type (Arr));
8509 end Is_Constrained_Packed_Array;
8511 ----------------------------------------
8512 -- Is_Inline_Floating_Point_Attribute --
8513 ----------------------------------------
8515 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8516 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8518 function Is_GCC_Target return Boolean;
8519 -- Return True if we are using a GCC target/back-end
8520 -- ??? Note: the implementation is kludgy/fragile
8526 function Is_GCC_Target return Boolean is
8528 return not CodePeer_Mode
8529 and then not Modify_Tree_For_C;
8532 -- Start of processing for Is_Inline_Floating_Point_Attribute
8535 -- Machine and Model can be expanded by the GCC back end only
8537 if Id = Attribute_Machine or else Id = Attribute_Model then
8538 return Is_GCC_Target;
8540 -- Remaining cases handled by all back ends are Rounding and Truncation
8541 -- when appearing as the operand of a conversion to some integer type.
8543 elsif Nkind (Parent (N)) /= N_Type_Conversion
8544 or else not Is_Integer_Type (Etype (Parent (N)))
8549 -- Here we are in the integer conversion context
8551 -- Very probably we should also recognize the cases of Machine_Rounding
8552 -- and unbiased rounding in this conversion context, but the back end is
8553 -- not yet prepared to handle these cases ???
8555 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8556 end Is_Inline_Floating_Point_Attribute;