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 Expander; use Expander;
43 with Freeze; use Freeze;
44 with Gnatvsn; use Gnatvsn;
45 with Itypes; use Itypes;
47 with Namet; use Namet;
48 with Nmake; use Nmake;
49 with Nlists; use Nlists;
51 with Restrict; use Restrict;
52 with Rident; use Rident;
53 with Rtsfind; use Rtsfind;
55 with Sem_Aux; use Sem_Aux;
56 with Sem_Ch6; use Sem_Ch6;
57 with Sem_Ch7; use Sem_Ch7;
58 with Sem_Ch8; use Sem_Ch8;
59 with Sem_Eval; use Sem_Eval;
60 with Sem_Res; use Sem_Res;
61 with Sem_Util; use Sem_Util;
62 with Sinfo; use Sinfo;
63 with Snames; use Snames;
64 with Stand; use Stand;
65 with Stringt; use Stringt;
66 with Tbuild; use Tbuild;
67 with Ttypes; use Ttypes;
68 with Uintp; use Uintp;
69 with Uname; use Uname;
70 with Validsw; use Validsw;
72 package body Exp_Attr is
74 -----------------------
75 -- Local Subprograms --
76 -----------------------
78 function Build_Array_VS_Func
80 Formal_Typ : Entity_Id;
81 Array_Typ : Entity_Id;
82 Comp_Typ : Entity_Id) return Entity_Id;
83 -- Validate the components of an array type by means of a function. Return
84 -- the entity of the validation function. The parameters are as follows:
86 -- * Attr - the 'Valid_Scalars attribute for which the function is
89 -- * Formal_Typ - the type of the generated function's only formal
92 -- * Array_Typ - the array type whose components are to be validated
94 -- * Comp_Typ - the component type of the array
96 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id;
97 -- Build a call to Disp_Get_Task_Id, passing Actual as actual parameter
99 function Build_Record_VS_Func
101 Formal_Typ : Entity_Id;
102 Rec_Typ : Entity_Id) return Entity_Id;
103 -- Validate the components, discriminants, and variants of a record type by
104 -- means of a function. Return the entity of the validation function. The
105 -- parameters are as follows:
107 -- * Attr - the 'Valid_Scalars attribute for which the function is
110 -- * Formal_Typ - the type of the generated function's only formal
113 -- * Rec_Typ - the record type whose internals are to be validated
115 procedure Compile_Stream_Body_In_Scope
120 -- The body for a stream subprogram may be generated outside of the scope
121 -- of the type. If the type is fully private, it may depend on the full
122 -- view of other types (e.g. indexes) that are currently private as well.
123 -- We install the declarations of the package in which the type is declared
124 -- before compiling the body in what is its proper environment. The Check
125 -- parameter indicates if checks are to be suppressed for the stream body.
126 -- We suppress checks for array/record reads, since the rule is that these
127 -- are like assignments, out of range values due to uninitialized storage,
128 -- or other invalid values do NOT cause a Constraint_Error to be raised.
129 -- If we are within an instance body all visibility has been established
130 -- already and there is no need to install the package.
132 -- This mechanism is now extended to the component types of the array type,
133 -- when the component type is not in scope and is private, to handle
134 -- properly the case when the full view has defaulted discriminants.
136 -- This special processing is ultimately caused by the fact that the
137 -- compiler lacks a well-defined phase when full views are visible
138 -- everywhere. Having such a separate pass would remove much of the
139 -- special-case code that shuffles partial and full views in the middle
140 -- of semantic analysis and expansion.
142 procedure Expand_Access_To_Protected_Op
146 -- An attribute reference to a protected subprogram is transformed into
147 -- a pair of pointers: one to the object, and one to the operations.
148 -- This expansion is performed for 'Access and for 'Unrestricted_Access.
150 procedure Expand_Fpt_Attribute
155 -- This procedure expands a call to a floating-point attribute function.
156 -- N is the attribute reference node, and Args is a list of arguments to
157 -- be passed to the function call. Pkg identifies the package containing
158 -- the appropriate instantiation of System.Fat_Gen. Float arguments in Args
159 -- have already been converted to the floating-point type for which Pkg was
160 -- instantiated. The Nam argument is the relevant attribute processing
161 -- routine to be called. This is the same as the attribute name, except in
162 -- the Unaligned_Valid case.
164 procedure Expand_Fpt_Attribute_R (N : Node_Id);
165 -- This procedure expands a call to a floating-point attribute function
166 -- that takes a single floating-point argument. The function to be called
167 -- is always the same as the attribute name.
169 procedure Expand_Fpt_Attribute_RI (N : Node_Id);
170 -- This procedure expands a call to a floating-point attribute function
171 -- that takes one floating-point argument and one integer argument. The
172 -- function to be called is always the same as the attribute name.
174 procedure Expand_Fpt_Attribute_RR (N : Node_Id);
175 -- This procedure expands a call to a floating-point attribute function
176 -- that takes two floating-point arguments. The function to be called
177 -- is always the same as the attribute name.
179 procedure Expand_Loop_Entry_Attribute (N : Node_Id);
180 -- Handle the expansion of attribute 'Loop_Entry. As a result, the related
181 -- loop may be converted into a conditional block. See body for details.
183 procedure Expand_Min_Max_Attribute (N : Node_Id);
184 -- Handle the expansion of attributes 'Max and 'Min, including expanding
185 -- then out if we are in Modify_Tree_For_C mode.
187 procedure Expand_Pred_Succ_Attribute (N : Node_Id);
188 -- Handles expansion of Pred or Succ attributes for case of non-real
189 -- operand with overflow checking required.
191 procedure Expand_Update_Attribute (N : Node_Id);
192 -- Handle the expansion of attribute Update
194 function Get_Index_Subtype (N : Node_Id) return Entity_Id;
195 -- Used for Last, Last, and Length, when the prefix is an array type.
196 -- Obtains the corresponding index subtype.
198 procedure Find_Fat_Info
200 Fat_Type : out Entity_Id;
201 Fat_Pkg : out RE_Id);
202 -- Given a floating-point type T, identifies the package containing the
203 -- attributes for this type (returned in Fat_Pkg), and the corresponding
204 -- type for which this package was instantiated from Fat_Gen. Error if T
205 -- is not a floating-point type.
207 function Find_Stream_Subprogram
209 Nam : TSS_Name_Type) return Entity_Id;
210 -- Returns the stream-oriented subprogram attribute for Typ. For tagged
211 -- types, the corresponding primitive operation is looked up, else the
212 -- appropriate TSS from the type itself, or from its closest ancestor
213 -- defining it, is returned. In both cases, inheritance of representation
214 -- aspects is thus taken into account.
216 function Full_Base (T : Entity_Id) return Entity_Id;
217 -- The stream functions need to examine the underlying representation of
218 -- composite types. In some cases T may be non-private but its base type
219 -- is, in which case the function returns the corresponding full view.
221 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
222 -- Given a type, find a corresponding stream convert pragma that applies to
223 -- the implementation base type of this type (Typ). If found, return the
224 -- pragma node, otherwise return Empty if no pragma is found.
226 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
227 -- Utility for array attributes, returns true on packed constrained
228 -- arrays, and on access to same.
230 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
231 -- Returns true iff the given node refers to an attribute call that
232 -- can be expanded directly by the back end and does not need front end
233 -- expansion. Typically used for rounding and truncation attributes that
234 -- appear directly inside a conversion to integer.
236 -------------------------
237 -- Build_Array_VS_Func --
238 -------------------------
240 function Build_Array_VS_Func
242 Formal_Typ : Entity_Id;
243 Array_Typ : Entity_Id;
244 Comp_Typ : Entity_Id) return Entity_Id
246 Loc : constant Source_Ptr := Sloc (Attr);
248 function Validate_Component
250 Indexes : List_Id) return Node_Id;
251 -- Process a single component denoted by indexes Indexes. Obj_Id denotes
252 -- the entity of the validation parameter. Return the check associated
253 -- with the component.
255 function Validate_Dimension
258 Indexes : List_Id) return Node_Id;
259 -- Process dimension Dim of the array type. Obj_Id denotes the entity
260 -- of the validation parameter. Indexes is a list where each dimension
261 -- deposits its loop variable, which will later identify a component.
262 -- Return the loop associated with the current dimension.
264 ------------------------
265 -- Validate_Component --
266 ------------------------
268 function Validate_Component
270 Indexes : List_Id) return Node_Id
275 if Is_Scalar_Type (Comp_Typ) then
276 Attr_Nam := Name_Valid;
278 Attr_Nam := Name_Valid_Scalars;
282 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars] then
287 Make_If_Statement (Loc,
291 Make_Attribute_Reference (Loc,
293 Make_Indexed_Component (Loc,
295 Unchecked_Convert_To (Array_Typ,
296 New_Occurrence_Of (Obj_Id, Loc)),
297 Expressions => Indexes),
298 Attribute_Name => Attr_Nam)),
300 Then_Statements => New_List (
301 Make_Simple_Return_Statement (Loc,
302 Expression => New_Occurrence_Of (Standard_False, Loc))));
303 end Validate_Component;
305 ------------------------
306 -- Validate_Dimension --
307 ------------------------
309 function Validate_Dimension
312 Indexes : List_Id) return Node_Id
317 -- Validate the component once all dimensions have produced their
320 if Dim > Number_Dimensions (Array_Typ) then
321 return Validate_Component (Obj_Id, Indexes);
323 -- Process the current dimension
327 Make_Defining_Identifier (Loc, New_External_Name ('J', Dim));
329 Append_To (Indexes, New_Occurrence_Of (Index, Loc));
332 -- for J1 in Array_Typ (Obj_Id)'Range (1) loop
333 -- for JN in Array_Typ (Obj_Id)'Range (N) loop
334 -- if not Array_Typ (Obj_Id) (Indexes)'Valid[_Scalars]
342 Make_Implicit_Loop_Statement (Attr,
345 Make_Iteration_Scheme (Loc,
346 Loop_Parameter_Specification =>
347 Make_Loop_Parameter_Specification (Loc,
348 Defining_Identifier => Index,
349 Discrete_Subtype_Definition =>
350 Make_Attribute_Reference (Loc,
352 Unchecked_Convert_To (Array_Typ,
353 New_Occurrence_Of (Obj_Id, Loc)),
354 Attribute_Name => Name_Range,
355 Expressions => New_List (
356 Make_Integer_Literal (Loc, Dim))))),
357 Statements => New_List (
358 Validate_Dimension (Obj_Id, Dim + 1, Indexes)));
360 end Validate_Dimension;
364 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
365 Indexes : constant List_Id := New_List;
366 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
369 -- Start of processing for Build_Array_VS_Func
372 Stmts := New_List (Validate_Dimension (Obj_Id, 1, Indexes));
378 Make_Simple_Return_Statement (Loc,
379 Expression => New_Occurrence_Of (Standard_True, Loc)));
382 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
387 Set_Ekind (Func_Id, E_Function);
388 Set_Is_Internal (Func_Id);
389 Set_Is_Pure (Func_Id);
391 if not Debug_Generated_Code then
392 Set_Debug_Info_Off (Func_Id);
396 Make_Subprogram_Body (Loc,
398 Make_Function_Specification (Loc,
399 Defining_Unit_Name => Func_Id,
400 Parameter_Specifications => New_List (
401 Make_Parameter_Specification (Loc,
402 Defining_Identifier => Obj_Id,
404 Out_Present => False,
405 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
407 New_Occurrence_Of (Standard_Boolean, Loc)),
408 Declarations => New_List,
409 Handled_Statement_Sequence =>
410 Make_Handled_Sequence_Of_Statements (Loc,
411 Statements => Stmts)));
414 end Build_Array_VS_Func;
416 ---------------------------------
417 -- Build_Disp_Get_Task_Id_Call --
418 ---------------------------------
420 function Build_Disp_Get_Task_Id_Call (Actual : Node_Id) return Node_Id is
421 Loc : constant Source_Ptr := Sloc (Actual);
422 Typ : constant Entity_Id := Etype (Actual);
423 Subp : constant Entity_Id := Find_Prim_Op (Typ, Name_uDisp_Get_Task_Id);
427 -- _Disp_Get_Task_Id (Actual)
430 Make_Function_Call (Loc,
431 Name => New_Occurrence_Of (Subp, Loc),
432 Parameter_Associations => New_List (Actual));
433 end Build_Disp_Get_Task_Id_Call;
435 --------------------------
436 -- Build_Record_VS_Func --
437 --------------------------
439 function Build_Record_VS_Func
441 Formal_Typ : Entity_Id;
442 Rec_Typ : Entity_Id) return Entity_Id
444 -- NOTE: The logic of Build_Record_VS_Func is intentionally passive.
445 -- It generates code only when there are components, discriminants,
446 -- or variant parts to validate.
448 -- NOTE: The routines within Build_Record_VS_Func are intentionally
449 -- unnested to avoid deep indentation of code.
451 Loc : constant Source_Ptr := Sloc (Attr);
453 procedure Validate_Component_List
456 Stmts : in out List_Id);
457 -- Process all components and variant parts of component list Comp_List.
458 -- Obj_Id denotes the entity of the validation parameter. All new code
459 -- is added to list Stmts.
461 procedure Validate_Field
464 Cond : in out Node_Id);
465 -- Process component declaration or discriminant specification Field.
466 -- Obj_Id denotes the entity of the validation parameter. Cond denotes
467 -- an "or else" conditional expression which contains the new code (if
470 procedure Validate_Fields
473 Stmts : in out List_Id);
474 -- Process component declarations or discriminant specifications in list
475 -- Fields. Obj_Id denotes the entity of the validation parameter. All
476 -- new code is added to list Stmts.
478 procedure Validate_Variant
481 Alts : in out List_Id);
482 -- Process variant Var. Obj_Id denotes the entity of the validation
483 -- parameter. Alts denotes a list of case statement alternatives which
484 -- contains the new code (if any).
486 procedure Validate_Variant_Part
489 Stmts : in out List_Id);
490 -- Process variant part Var_Part. Obj_Id denotes the entity of the
491 -- validation parameter. All new code is added to list Stmts.
493 -----------------------------
494 -- Validate_Component_List --
495 -----------------------------
497 procedure Validate_Component_List
500 Stmts : in out List_Id)
502 Var_Part : constant Node_Id := Variant_Part (Comp_List);
505 -- Validate all components
509 Fields => Component_Items (Comp_List),
512 -- Validate the variant part
514 if Present (Var_Part) then
515 Validate_Variant_Part
517 Var_Part => Var_Part,
520 end Validate_Component_List;
526 procedure Validate_Field
529 Cond : in out Node_Id)
531 Field_Id : constant Entity_Id := Defining_Entity (Field);
532 Field_Nam : constant Name_Id := Chars (Field_Id);
533 Field_Typ : constant Entity_Id := Validated_View (Etype (Field_Id));
537 -- Do not process internally-generated fields. Note that checking for
538 -- Comes_From_Source is not correct because this will eliminate the
539 -- components within the corresponding record of a protected type.
541 if Nam_In (Field_Nam, Name_uObject,
547 -- Do not process fields without any scalar components
549 elsif not Scalar_Part_Present (Field_Typ) then
552 -- Otherwise the field needs to be validated. Use Make_Identifier
553 -- rather than New_Occurrence_Of to identify the field because the
554 -- wrong entity may be picked up when private types are involved.
557 -- [or else] not Rec_Typ (Obj_Id).Item_Nam'Valid[_Scalars]
560 if Is_Scalar_Type (Field_Typ) then
561 Attr_Nam := Name_Valid;
563 Attr_Nam := Name_Valid_Scalars;
566 Evolve_Or_Else (Cond,
569 Make_Attribute_Reference (Loc,
571 Make_Selected_Component (Loc,
573 Unchecked_Convert_To (Rec_Typ,
574 New_Occurrence_Of (Obj_Id, Loc)),
575 Selector_Name => Make_Identifier (Loc, Field_Nam)),
576 Attribute_Name => Attr_Nam)));
580 ---------------------
581 -- Validate_Fields --
582 ---------------------
584 procedure Validate_Fields
587 Stmts : in out List_Id)
593 -- Assume that none of the fields are eligible for verification
597 -- Validate all fields
599 Field := First_Non_Pragma (Fields);
600 while Present (Field) loop
606 Next_Non_Pragma (Field);
610 -- if not Rec_Typ (Obj_Id).Item_Nam_1'Valid[_Scalars]
611 -- or else not Rec_Typ (Obj_Id).Item_Nam_N'Valid[_Scalars]
616 if Present (Cond) then
617 Append_New_To (Stmts,
618 Make_Implicit_If_Statement (Attr,
620 Then_Statements => New_List (
621 Make_Simple_Return_Statement (Loc,
622 Expression => New_Occurrence_Of (Standard_False, Loc)))));
626 ----------------------
627 -- Validate_Variant --
628 ----------------------
630 procedure Validate_Variant
633 Alts : in out List_Id)
638 -- Assume that none of the components and variants are eligible for
643 -- Validate components
645 Validate_Component_List
647 Comp_List => Component_List (Var),
650 -- Generate a null statement in case none of the components were
651 -- verified because this will otherwise eliminate an alternative
652 -- from the variant case statement and render the generated code
656 Append_New_To (Stmts, Make_Null_Statement (Loc));
660 -- when Discrete_Choices =>
664 Make_Case_Statement_Alternative (Loc,
666 New_Copy_List_Tree (Discrete_Choices (Var)),
667 Statements => Stmts));
668 end Validate_Variant;
670 ---------------------------
671 -- Validate_Variant_Part --
672 ---------------------------
674 procedure Validate_Variant_Part
677 Stmts : in out List_Id)
679 Vars : constant List_Id := Variants (Var_Part);
684 -- Assume that none of the variants are eligible for verification
690 Var := First_Non_Pragma (Vars);
691 while Present (Var) loop
697 Next_Non_Pragma (Var);
700 -- Even though individual variants may lack eligible components, the
701 -- alternatives must still be generated.
703 pragma Assert (Present (Alts));
706 -- case Rec_Typ (Obj_Id).Discriminant is
707 -- when Discrete_Choices_1 =>
709 -- when Discrete_Choices_N =>
713 Append_New_To (Stmts,
714 Make_Case_Statement (Loc,
716 Make_Selected_Component (Loc,
718 Unchecked_Convert_To (Rec_Typ,
719 New_Occurrence_Of (Obj_Id, Loc)),
720 Selector_Name => New_Copy_Tree (Name (Var_Part))),
721 Alternatives => Alts));
722 end Validate_Variant_Part;
726 Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V');
727 Obj_Id : constant Entity_Id := Make_Temporary (Loc, 'R');
735 -- Start of processing for Build_Record_VS_Func
740 -- Use the root type when dealing with a class-wide type
742 if Is_Class_Wide_Type (Typ) then
743 Typ := Root_Type (Typ);
746 Typ_Decl := Declaration_Node (Typ);
747 Typ_Def := Type_Definition (Typ_Decl);
749 -- The components of a derived type are located in the extension part
751 if Nkind (Typ_Def) = N_Derived_Type_Definition then
752 Typ_Ext := Record_Extension_Part (Typ_Def);
754 if Present (Typ_Ext) then
755 Comps := Component_List (Typ_Ext);
760 -- Otherwise the components are available in the definition
763 Comps := Component_List (Typ_Def);
766 -- The code generated by this routine is as follows:
768 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
770 -- if not Rec_Typ (Obj_Id).Discriminant_1'Valid[_Scalars]
771 -- or else not Rec_Typ (Obj_Id).Discriminant_N'Valid[_Scalars]
776 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
777 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
782 -- case Discriminant_1 is
784 -- if not Rec_Typ (Obj_Id).Component_1'Valid[_Scalars]
785 -- or else not Rec_Typ (Obj_Id).Component_N'Valid[_Scalars]
790 -- case Discriminant_N is
799 -- Assume that the record type lacks eligible components, discriminants,
800 -- and variant parts.
804 -- Validate the discriminants
806 if not Is_Unchecked_Union (Rec_Typ) then
809 Fields => Discriminant_Specifications (Typ_Decl),
813 -- Validate the components and variant parts
815 Validate_Component_List
823 Append_New_To (Stmts,
824 Make_Simple_Return_Statement (Loc,
825 Expression => New_Occurrence_Of (Standard_True, Loc)));
828 -- function Func_Id (Obj_Id : Formal_Typ) return Boolean is
833 Set_Ekind (Func_Id, E_Function);
834 Set_Is_Internal (Func_Id);
835 Set_Is_Pure (Func_Id);
837 if not Debug_Generated_Code then
838 Set_Debug_Info_Off (Func_Id);
842 Make_Subprogram_Body (Loc,
844 Make_Function_Specification (Loc,
845 Defining_Unit_Name => Func_Id,
846 Parameter_Specifications => New_List (
847 Make_Parameter_Specification (Loc,
848 Defining_Identifier => Obj_Id,
849 Parameter_Type => New_Occurrence_Of (Formal_Typ, Loc))),
851 New_Occurrence_Of (Standard_Boolean, Loc)),
852 Declarations => New_List,
853 Handled_Statement_Sequence =>
854 Make_Handled_Sequence_Of_Statements (Loc,
855 Statements => Stmts)),
856 Suppress => Discriminant_Check);
859 end Build_Record_VS_Func;
861 ----------------------------------
862 -- Compile_Stream_Body_In_Scope --
863 ----------------------------------
865 procedure Compile_Stream_Body_In_Scope
871 C_Type : constant Entity_Id := Base_Type (Component_Type (Arr));
872 Curr : constant Entity_Id := Current_Scope;
873 Install : Boolean := False;
874 Scop : Entity_Id := Scope (Arr);
878 and then not In_Open_Scopes (Scop)
879 and then Ekind (Scop) = E_Package
884 -- The component type may be private, in which case we install its
885 -- full view to compile the subprogram.
887 -- The component type may be private, in which case we install its
888 -- full view to compile the subprogram. We do not do this if the
889 -- type has a Stream_Convert pragma, which indicates that there are
890 -- special stream-processing operations for that type (for example
891 -- Unbounded_String and its wide varieties).
893 Scop := Scope (C_Type);
895 if Is_Private_Type (C_Type)
896 and then Present (Full_View (C_Type))
897 and then not In_Open_Scopes (Scop)
898 and then Ekind (Scop) = E_Package
899 and then No (Get_Stream_Convert_Pragma (C_Type))
905 -- If we are within an instance body, then all visibility has been
906 -- established already and there is no need to install the package.
908 if Install and then not In_Instance_Body then
910 Install_Visible_Declarations (Scop);
911 Install_Private_Declarations (Scop);
913 -- The entities in the package are now visible, but the generated
914 -- stream entity must appear in the current scope (usually an
915 -- enclosing stream function) so that itypes all have their proper
924 Insert_Action (N, Decl);
926 Insert_Action (N, Decl, Suppress => All_Checks);
931 -- Remove extra copy of current scope, and package itself
934 End_Package_Scope (Scop);
936 end Compile_Stream_Body_In_Scope;
938 -----------------------------------
939 -- Expand_Access_To_Protected_Op --
940 -----------------------------------
942 procedure Expand_Access_To_Protected_Op
947 -- The value of the attribute_reference is a record containing two
948 -- fields: an access to the protected object, and an access to the
949 -- subprogram itself. The prefix is a selected component.
951 Loc : constant Source_Ptr := Sloc (N);
953 Btyp : constant Entity_Id := Base_Type (Typ);
956 E_T : constant Entity_Id := Equivalent_Type (Btyp);
957 Acc : constant Entity_Id :=
958 Etype (Next_Component (First_Component (E_T)));
962 -- Start of processing for Expand_Access_To_Protected_Op
965 -- Within the body of the protected type, the prefix designates a local
966 -- operation, and the object is the first parameter of the corresponding
967 -- protected body of the current enclosing operation.
969 if Is_Entity_Name (Pref) then
970 -- All indirect calls are external calls, so must do locking and
971 -- barrier reevaluation, even if the 'Access occurs within the
972 -- protected body. Hence the call to External_Subprogram, as opposed
973 -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means
974 -- that indirect calls from within the same protected body will
975 -- deadlock, as allowed by RM-9.5.1(8,15,17).
977 Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
979 -- Don't traverse the scopes when the attribute occurs within an init
980 -- proc, because we directly use the _init formal of the init proc in
983 Curr := Current_Scope;
984 if not Is_Init_Proc (Curr) then
985 pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
987 while Scope (Curr) /= Scope (Entity (Pref)) loop
988 Curr := Scope (Curr);
992 -- In case of protected entries the first formal of its Protected_
993 -- Body_Subprogram is the address of the object.
995 if Ekind (Curr) = E_Entry then
999 (Protected_Body_Subprogram (Curr)), Loc);
1001 -- If the current scope is an init proc, then use the address of the
1002 -- _init formal as the object reference.
1004 elsif Is_Init_Proc (Curr) then
1006 Make_Attribute_Reference (Loc,
1007 Prefix => New_Occurrence_Of (First_Formal (Curr), Loc),
1008 Attribute_Name => Name_Address);
1010 -- In case of protected subprograms the first formal of its
1011 -- Protected_Body_Subprogram is the object and we get its address.
1015 Make_Attribute_Reference (Loc,
1019 (Protected_Body_Subprogram (Curr)), Loc),
1020 Attribute_Name => Name_Address);
1023 -- Case where the prefix is not an entity name. Find the
1024 -- version of the protected operation to be called from
1025 -- outside the protected object.
1030 (External_Subprogram
1031 (Entity (Selector_Name (Pref))), Loc);
1034 Make_Attribute_Reference (Loc,
1035 Prefix => Relocate_Node (Prefix (Pref)),
1036 Attribute_Name => Name_Address);
1040 Make_Attribute_Reference (Loc,
1042 Attribute_Name => Name_Access);
1044 -- We set the type of the access reference to the already generated
1045 -- access_to_subprogram type, and declare the reference analyzed, to
1046 -- prevent further expansion when the enclosing aggregate is analyzed.
1048 Set_Etype (Sub_Ref, Acc);
1049 Set_Analyzed (Sub_Ref);
1052 Make_Aggregate (Loc,
1053 Expressions => New_List (Obj_Ref, Sub_Ref));
1055 -- Sub_Ref has been marked as analyzed, but we still need to make sure
1056 -- Sub is correctly frozen.
1058 Freeze_Before (N, Entity (Sub));
1061 Analyze_And_Resolve (N, E_T);
1063 -- For subsequent analysis, the node must retain its type. The backend
1064 -- will replace it with the equivalent type where needed.
1067 end Expand_Access_To_Protected_Op;
1069 --------------------------
1070 -- Expand_Fpt_Attribute --
1071 --------------------------
1073 procedure Expand_Fpt_Attribute
1079 Loc : constant Source_Ptr := Sloc (N);
1080 Typ : constant Entity_Id := Etype (N);
1084 -- The function name is the selected component Attr_xxx.yyy where
1085 -- Attr_xxx is the package name, and yyy is the argument Nam.
1087 -- Note: it would be more usual to have separate RE entries for each
1088 -- of the entities in the Fat packages, but first they have identical
1089 -- names (so we would have to have lots of renaming declarations to
1090 -- meet the normal RE rule of separate names for all runtime entities),
1091 -- and second there would be an awful lot of them.
1094 Make_Selected_Component (Loc,
1095 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
1096 Selector_Name => Make_Identifier (Loc, Nam));
1098 -- The generated call is given the provided set of parameters, and then
1099 -- wrapped in a conversion which converts the result to the target type
1100 -- We use the base type as the target because a range check may be
1104 Unchecked_Convert_To (Base_Type (Etype (N)),
1105 Make_Function_Call (Loc,
1107 Parameter_Associations => Args)));
1109 Analyze_And_Resolve (N, Typ);
1110 end Expand_Fpt_Attribute;
1112 ----------------------------
1113 -- Expand_Fpt_Attribute_R --
1114 ----------------------------
1116 -- The single argument is converted to its root type to call the
1117 -- appropriate runtime function, with the actual call being built
1118 -- by Expand_Fpt_Attribute
1120 procedure Expand_Fpt_Attribute_R (N : Node_Id) is
1121 E1 : constant Node_Id := First (Expressions (N));
1125 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1126 Expand_Fpt_Attribute
1127 (N, Pkg, Attribute_Name (N),
1128 New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
1129 end Expand_Fpt_Attribute_R;
1131 -----------------------------
1132 -- Expand_Fpt_Attribute_RI --
1133 -----------------------------
1135 -- The first argument is converted to its root type and the second
1136 -- argument is converted to standard long long integer to call the
1137 -- appropriate runtime function, with the actual call being built
1138 -- by Expand_Fpt_Attribute
1140 procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
1141 E1 : constant Node_Id := First (Expressions (N));
1144 E2 : constant Node_Id := Next (E1);
1146 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1147 Expand_Fpt_Attribute
1148 (N, Pkg, Attribute_Name (N),
1150 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
1151 Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
1152 end Expand_Fpt_Attribute_RI;
1154 -----------------------------
1155 -- Expand_Fpt_Attribute_RR --
1156 -----------------------------
1158 -- The two arguments are converted to their root types to call the
1159 -- appropriate runtime function, with the actual call being built
1160 -- by Expand_Fpt_Attribute
1162 procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
1163 E1 : constant Node_Id := First (Expressions (N));
1164 E2 : constant Node_Id := Next (E1);
1169 Find_Fat_Info (Etype (E1), Ftp, Pkg);
1170 Expand_Fpt_Attribute
1171 (N, Pkg, Attribute_Name (N),
1173 Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
1174 Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
1175 end Expand_Fpt_Attribute_RR;
1177 ---------------------------------
1178 -- Expand_Loop_Entry_Attribute --
1179 ---------------------------------
1181 procedure Expand_Loop_Entry_Attribute (N : Node_Id) is
1182 procedure Build_Conditional_Block
1185 Loop_Stmt : Node_Id;
1186 If_Stmt : out Node_Id;
1187 Blk_Stmt : out Node_Id);
1188 -- Create a block Blk_Stmt with an empty declarative list and a single
1189 -- loop Loop_Stmt. The block is encased in an if statement If_Stmt with
1190 -- condition Cond. If_Stmt is Empty when there is no condition provided.
1192 function Is_Array_Iteration (N : Node_Id) return Boolean;
1193 -- Determine whether loop statement N denotes an Ada 2012 iteration over
1196 -----------------------------
1197 -- Build_Conditional_Block --
1198 -----------------------------
1200 procedure Build_Conditional_Block
1203 Loop_Stmt : Node_Id;
1204 If_Stmt : out Node_Id;
1205 Blk_Stmt : out Node_Id)
1208 -- Do not reanalyze the original loop statement because it is simply
1211 Set_Analyzed (Loop_Stmt);
1214 Make_Block_Statement (Loc,
1215 Declarations => New_List,
1216 Handled_Statement_Sequence =>
1217 Make_Handled_Sequence_Of_Statements (Loc,
1218 Statements => New_List (Loop_Stmt)));
1220 if Present (Cond) then
1222 Make_If_Statement (Loc,
1224 Then_Statements => New_List (Blk_Stmt));
1228 end Build_Conditional_Block;
1230 ------------------------
1231 -- Is_Array_Iteration --
1232 ------------------------
1234 function Is_Array_Iteration (N : Node_Id) return Boolean is
1235 Stmt : constant Node_Id := Original_Node (N);
1239 if Nkind (Stmt) = N_Loop_Statement
1240 and then Present (Iteration_Scheme (Stmt))
1241 and then Present (Iterator_Specification (Iteration_Scheme (Stmt)))
1243 Iter := Iterator_Specification (Iteration_Scheme (Stmt));
1246 Of_Present (Iter) and then Is_Array_Type (Etype (Name (Iter)));
1250 end Is_Array_Iteration;
1254 Pref : constant Node_Id := Prefix (N);
1255 Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
1256 Exprs : constant List_Id := Expressions (N);
1258 Blk : Node_Id := Empty;
1260 Installed : Boolean;
1262 Loop_Id : Entity_Id;
1263 Loop_Stmt : Node_Id;
1264 Result : Node_Id := Empty;
1266 Temp_Decl : Node_Id;
1267 Temp_Id : Entity_Id;
1269 -- Start of processing for Expand_Loop_Entry_Attribute
1272 -- Step 1: Find the related loop
1274 -- The loop label variant of attribute 'Loop_Entry already has all the
1275 -- information in its expression.
1277 if Present (Exprs) then
1278 Loop_Id := Entity (First (Exprs));
1279 Loop_Stmt := Label_Construct (Parent (Loop_Id));
1281 -- Climb the parent chain to find the nearest enclosing loop. Skip
1282 -- all internally generated loops for quantified expressions and for
1283 -- element iterators over multidimensional arrays because the pragma
1284 -- applies to source loop.
1288 while Present (Loop_Stmt) loop
1289 if Nkind (Loop_Stmt) = N_Loop_Statement
1290 and then Nkind (Original_Node (Loop_Stmt)) = N_Loop_Statement
1291 and then Comes_From_Source (Original_Node (Loop_Stmt))
1296 Loop_Stmt := Parent (Loop_Stmt);
1299 Loop_Id := Entity (Identifier (Loop_Stmt));
1302 Loc := Sloc (Loop_Stmt);
1304 -- Step 2: Transform the loop
1306 -- The loop has already been transformed during the expansion of a prior
1307 -- 'Loop_Entry attribute. Retrieve the declarative list of the block.
1309 if Has_Loop_Entry_Attributes (Loop_Id) then
1311 -- When the related loop name appears as the argument of attribute
1312 -- Loop_Entry, the corresponding label construct is the generated
1313 -- block statement. This is because the expander reuses the label.
1315 if Nkind (Loop_Stmt) = N_Block_Statement then
1316 Decls := Declarations (Loop_Stmt);
1318 -- In all other cases, the loop must appear in the handled sequence
1319 -- of statements of the generated block.
1323 (Nkind (Parent (Loop_Stmt)) = N_Handled_Sequence_Of_Statements
1325 Nkind (Parent (Parent (Loop_Stmt))) = N_Block_Statement);
1327 Decls := Declarations (Parent (Parent (Loop_Stmt)));
1330 -- Transform the loop into a conditional block
1333 Set_Has_Loop_Entry_Attributes (Loop_Id);
1334 Scheme := Iteration_Scheme (Loop_Stmt);
1336 -- Infinite loops are transformed into:
1339 -- Temp1 : constant <type of Pref1> := <Pref1>;
1341 -- TempN : constant <type of PrefN> := <PrefN>;
1344 -- <original source statements with attribute rewrites>
1349 Build_Conditional_Block (Loc,
1351 Loop_Stmt => Relocate_Node (Loop_Stmt),
1357 -- While loops are transformed into:
1359 -- function Fnn return Boolean is
1361 -- <condition actions>
1362 -- return <condition>;
1367 -- Temp1 : constant <type of Pref1> := <Pref1>;
1369 -- TempN : constant <type of PrefN> := <PrefN>;
1372 -- <original source statements with attribute rewrites>
1373 -- exit when not Fnn;
1378 -- Note that loops over iterators and containers are already
1379 -- converted into while loops.
1381 elsif Present (Condition (Scheme)) then
1383 Func_Decl : Node_Id;
1384 Func_Id : Entity_Id;
1388 Func_Id := Make_Temporary (Loc, 'F');
1390 -- Wrap the condition of the while loop in a Boolean function.
1391 -- This avoids the duplication of the same code which may lead
1392 -- to gigi issues with respect to multiple declaration of the
1393 -- same entity in the presence of side effects or checks. Note
1394 -- that the condition actions must also be relocated into the
1395 -- wrapping function because they may contain itypes, e.g. in
1396 -- the case of a comparison involving slices.
1399 -- <condition actions>
1400 -- return <condition>;
1402 if Present (Condition_Actions (Scheme)) then
1403 Stmts := Condition_Actions (Scheme);
1409 Make_Simple_Return_Statement (Loc,
1411 New_Copy_Tree (Condition (Scheme),
1412 New_Scope => Func_Id)));
1415 -- function Fnn return Boolean is
1421 Make_Subprogram_Body (Loc,
1423 Make_Function_Specification (Loc,
1424 Defining_Unit_Name => Func_Id,
1425 Result_Definition =>
1426 New_Occurrence_Of (Standard_Boolean, Loc)),
1427 Declarations => Empty_List,
1428 Handled_Statement_Sequence =>
1429 Make_Handled_Sequence_Of_Statements (Loc,
1430 Statements => Stmts));
1432 -- The function is inserted before the related loop. Make sure
1433 -- to analyze it in the context of the loop's enclosing scope.
1435 Push_Scope (Scope (Loop_Id));
1436 Insert_Action (Loop_Stmt, Func_Decl);
1439 -- Transform the original while loop into an infinite loop
1440 -- where the last statement checks the negated condition. This
1441 -- placement ensures that the condition will not be evaluated
1442 -- twice on the first iteration.
1444 Set_Iteration_Scheme (Loop_Stmt, Empty);
1448 -- exit when not Fnn;
1450 Append_To (Statements (Loop_Stmt),
1451 Make_Exit_Statement (Loc,
1455 Make_Function_Call (Loc,
1456 Name => New_Occurrence_Of (Func_Id, Loc)))));
1458 Build_Conditional_Block (Loc,
1460 Make_Function_Call (Loc,
1461 Name => New_Occurrence_Of (Func_Id, Loc)),
1462 Loop_Stmt => Relocate_Node (Loop_Stmt),
1467 -- Ada 2012 iteration over an array is transformed into:
1469 -- if <Array_Nam>'Length (1) > 0
1470 -- and then <Array_Nam>'Length (N) > 0
1473 -- Temp1 : constant <type of Pref1> := <Pref1>;
1475 -- TempN : constant <type of PrefN> := <PrefN>;
1477 -- for X in ... loop -- multiple loops depending on dims
1478 -- <original source statements with attribute rewrites>
1483 elsif Is_Array_Iteration (Loop_Stmt) then
1485 Array_Nam : constant Entity_Id :=
1486 Entity (Name (Iterator_Specification
1487 (Iteration_Scheme (Original_Node (Loop_Stmt)))));
1488 Num_Dims : constant Pos :=
1489 Number_Dimensions (Etype (Array_Nam));
1490 Cond : Node_Id := Empty;
1494 -- Generate a check which determines whether all dimensions of
1495 -- the array are non-null.
1497 for Dim in 1 .. Num_Dims loop
1501 Make_Attribute_Reference (Loc,
1502 Prefix => New_Occurrence_Of (Array_Nam, Loc),
1503 Attribute_Name => Name_Length,
1504 Expressions => New_List (
1505 Make_Integer_Literal (Loc, Dim))),
1507 Make_Integer_Literal (Loc, 0));
1515 Right_Opnd => Check);
1519 Build_Conditional_Block (Loc,
1521 Loop_Stmt => Relocate_Node (Loop_Stmt),
1526 -- For loops are transformed into:
1528 -- if <Low> <= <High> then
1530 -- Temp1 : constant <type of Pref1> := <Pref1>;
1532 -- TempN : constant <type of PrefN> := <PrefN>;
1534 -- for <Def_Id> in <Low> .. <High> loop
1535 -- <original source statements with attribute rewrites>
1540 elsif Present (Loop_Parameter_Specification (Scheme)) then
1542 Loop_Spec : constant Node_Id :=
1543 Loop_Parameter_Specification (Scheme);
1548 Subt_Def := Discrete_Subtype_Definition (Loop_Spec);
1550 -- When the loop iterates over a subtype indication with a
1551 -- range, use the low and high bounds of the subtype itself.
1553 if Nkind (Subt_Def) = N_Subtype_Indication then
1554 Subt_Def := Scalar_Range (Etype (Subt_Def));
1557 pragma Assert (Nkind (Subt_Def) = N_Range);
1564 Left_Opnd => New_Copy_Tree (Low_Bound (Subt_Def)),
1565 Right_Opnd => New_Copy_Tree (High_Bound (Subt_Def)));
1567 Build_Conditional_Block (Loc,
1569 Loop_Stmt => Relocate_Node (Loop_Stmt),
1575 Decls := Declarations (Blk);
1578 -- Step 3: Create a constant to capture the value of the prefix at the
1579 -- entry point into the loop.
1581 Temp_Id := Make_Temporary (Loc, 'P');
1583 -- Preserve the tag of the prefix by offering a specific view of the
1584 -- class-wide version of the prefix.
1586 if Is_Tagged_Type (Base_Typ) then
1587 Tagged_Case : declare
1588 CW_Temp : Entity_Id;
1593 -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
1595 CW_Temp := Make_Temporary (Loc, 'T');
1596 CW_Typ := Class_Wide_Type (Base_Typ);
1599 Make_Object_Declaration (Loc,
1600 Defining_Identifier => CW_Temp,
1601 Constant_Present => True,
1602 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
1604 Convert_To (CW_Typ, Relocate_Node (Pref)));
1605 Append_To (Decls, Aux_Decl);
1608 -- Temp : Base_Typ renames Base_Typ (CW_Temp);
1611 Make_Object_Renaming_Declaration (Loc,
1612 Defining_Identifier => Temp_Id,
1613 Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
1615 Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
1616 Append_To (Decls, Temp_Decl);
1622 Untagged_Case : declare
1623 Temp_Expr : Node_Id;
1628 -- Generate a nominal type for the constant when the prefix is of
1629 -- a constrained type. This is achieved by setting the Etype of
1630 -- the relocated prefix to its base type. Since the prefix is now
1631 -- the initialization expression of the constant, its freezing
1632 -- will produce a proper nominal type.
1634 Temp_Expr := Relocate_Node (Pref);
1635 Set_Etype (Temp_Expr, Base_Typ);
1638 -- Temp : constant Base_Typ := Pref;
1641 Make_Object_Declaration (Loc,
1642 Defining_Identifier => Temp_Id,
1643 Constant_Present => True,
1644 Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
1645 Expression => Temp_Expr);
1646 Append_To (Decls, Temp_Decl);
1650 -- Step 4: Analyze all bits
1652 Installed := Current_Scope = Scope (Loop_Id);
1654 -- Depending on the pracement of attribute 'Loop_Entry relative to the
1655 -- associated loop, ensure the proper visibility for analysis.
1657 if not Installed then
1658 Push_Scope (Scope (Loop_Id));
1661 -- The analysis of the conditional block takes care of the constant
1664 if Present (Result) then
1665 Rewrite (Loop_Stmt, Result);
1666 Analyze (Loop_Stmt);
1668 -- The conditional block was analyzed when a previous 'Loop_Entry was
1669 -- expanded. There is no point in reanalyzing the block, simply analyze
1670 -- the declaration of the constant.
1673 if Present (Aux_Decl) then
1677 Analyze (Temp_Decl);
1680 Rewrite (N, New_Occurrence_Of (Temp_Id, Loc));
1683 if not Installed then
1686 end Expand_Loop_Entry_Attribute;
1688 ------------------------------
1689 -- Expand_Min_Max_Attribute --
1690 ------------------------------
1692 procedure Expand_Min_Max_Attribute (N : Node_Id) is
1694 -- Min and Max are handled by the back end (except that static cases
1695 -- have already been evaluated during semantic processing, although the
1696 -- back end should not count on this). The one bit of special processing
1697 -- required in the normal case is that these two attributes typically
1698 -- generate conditionals in the code, so check the relevant restriction.
1700 Check_Restriction (No_Implicit_Conditionals, N);
1701 end Expand_Min_Max_Attribute;
1703 ----------------------------------
1704 -- Expand_N_Attribute_Reference --
1705 ----------------------------------
1707 procedure Expand_N_Attribute_Reference (N : Node_Id) is
1708 Loc : constant Source_Ptr := Sloc (N);
1709 Typ : constant Entity_Id := Etype (N);
1710 Btyp : constant Entity_Id := Base_Type (Typ);
1711 Pref : constant Node_Id := Prefix (N);
1712 Ptyp : constant Entity_Id := Etype (Pref);
1713 Exprs : constant List_Id := Expressions (N);
1714 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
1716 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
1717 -- Rewrites a stream attribute for Read, Write or Output with the
1718 -- procedure call. Pname is the entity for the procedure to call.
1720 ------------------------------
1721 -- Rewrite_Stream_Proc_Call --
1722 ------------------------------
1724 procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
1725 Item : constant Node_Id := Next (First (Exprs));
1726 Item_Typ : constant Entity_Id := Etype (Item);
1727 Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
1728 Formal_Typ : constant Entity_Id := Etype (Formal);
1729 Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
1732 -- The expansion depends on Item, the second actual, which is
1733 -- the object being streamed in or out.
1735 -- If the item is a component of a packed array type, and
1736 -- a conversion is needed on exit, we introduce a temporary to
1737 -- hold the value, because otherwise the packed reference will
1738 -- not be properly expanded.
1740 if Nkind (Item) = N_Indexed_Component
1741 and then Is_Packed (Base_Type (Etype (Prefix (Item))))
1742 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1746 Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
1752 Make_Object_Declaration (Loc,
1753 Defining_Identifier => Temp,
1754 Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
1755 Set_Etype (Temp, Formal_Typ);
1758 Make_Assignment_Statement (Loc,
1759 Name => New_Copy_Tree (Item),
1761 Unchecked_Convert_To
1762 (Item_Typ, New_Occurrence_Of (Temp, Loc)));
1764 Rewrite (Item, New_Occurrence_Of (Temp, Loc));
1768 Make_Procedure_Call_Statement (Loc,
1769 Name => New_Occurrence_Of (Pname, Loc),
1770 Parameter_Associations => Exprs),
1773 Rewrite (N, Make_Null_Statement (Loc));
1778 -- For the class-wide dispatching cases, and for cases in which
1779 -- the base type of the second argument matches the base type of
1780 -- the corresponding formal parameter (that is to say the stream
1781 -- operation is not inherited), we are all set, and can use the
1782 -- argument unchanged.
1784 if not Is_Class_Wide_Type (Entity (Pref))
1785 and then not Is_Class_Wide_Type (Etype (Item))
1786 and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
1788 -- Perform a view conversion when either the argument or the
1789 -- formal parameter are of a private type.
1791 if Is_Private_Type (Base_Type (Formal_Typ))
1792 or else Is_Private_Type (Base_Type (Item_Typ))
1795 Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
1797 -- Otherwise perform a regular type conversion to ensure that all
1798 -- relevant checks are installed.
1801 Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
1804 -- For untagged derived types set Assignment_OK, to prevent
1805 -- copies from being created when the unchecked conversion
1806 -- is expanded (which would happen in Remove_Side_Effects
1807 -- if Expand_N_Unchecked_Conversion were allowed to call
1808 -- Force_Evaluation). The copy could violate Ada semantics in
1809 -- cases such as an actual that is an out parameter. Note that
1810 -- this approach is also used in exp_ch7 for calls to controlled
1811 -- type operations to prevent problems with actuals wrapped in
1812 -- unchecked conversions.
1814 if Is_Untagged_Derivation (Etype (Expression (Item))) then
1815 Set_Assignment_OK (Item);
1819 -- The stream operation to call may be a renaming created by an
1820 -- attribute definition clause, and may not be frozen yet. Ensure
1821 -- that it has the necessary extra formals.
1823 if not Is_Frozen (Pname) then
1824 Create_Extra_Formals (Pname);
1827 -- And now rewrite the call
1830 Make_Procedure_Call_Statement (Loc,
1831 Name => New_Occurrence_Of (Pname, Loc),
1832 Parameter_Associations => Exprs));
1835 end Rewrite_Stream_Proc_Call;
1837 -- Start of processing for Expand_N_Attribute_Reference
1840 -- Do required validity checking, if enabled. Do not apply check to
1841 -- output parameters of an Asm instruction, since the value of this
1842 -- is not set till after the attribute has been elaborated, and do
1843 -- not apply the check to the arguments of a 'Read or 'Input attribute
1844 -- reference since the scalar argument is an OUT scalar.
1846 if Validity_Checks_On and then Validity_Check_Operands
1847 and then Id /= Attribute_Asm_Output
1848 and then Id /= Attribute_Read
1849 and then Id /= Attribute_Input
1854 Expr := First (Expressions (N));
1855 while Present (Expr) loop
1856 Ensure_Valid (Expr);
1862 -- Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
1863 -- place function, then a temporary return object needs to be created
1864 -- and access to it must be passed to the function.
1866 if Is_Build_In_Place_Function_Call (Pref) then
1868 -- If attribute is 'Old, the context is a postcondition, and
1869 -- the temporary must go in the corresponding subprogram, not
1870 -- the postcondition function or any created blocks, as when
1871 -- the attribute appears in a quantified expression. This is
1872 -- handled below in the expansion of the attribute.
1874 if Attribute_Name (Parent (Pref)) = Name_Old then
1877 Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
1880 -- Ada 2005 (AI-318-02): Specialization of the previous case for prefix
1881 -- containing build-in-place function calls whose returned object covers
1884 elsif Present (Unqual_BIP_Iface_Function_Call (Pref)) then
1885 Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Pref);
1888 -- If prefix is a protected type name, this is a reference to the
1889 -- current instance of the type. For a component definition, nothing
1890 -- to do (expansion will occur in the init proc). In other contexts,
1891 -- rewrite into reference to current instance.
1893 if Is_Protected_Self_Reference (Pref)
1895 (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
1896 N_Discriminant_Association)
1897 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
1898 N_Component_Definition)
1900 -- No action needed for these attributes since the current instance
1901 -- will be rewritten to be the name of the _object parameter
1902 -- associated with the enclosing protected subprogram (see below).
1904 and then Id /= Attribute_Access
1905 and then Id /= Attribute_Unchecked_Access
1906 and then Id /= Attribute_Unrestricted_Access
1908 Rewrite (Pref, Concurrent_Ref (Pref));
1912 -- Remaining processing depends on specific attribute
1914 -- Note: individual sections of the following case statement are
1915 -- allowed to assume there is no code after the case statement, and
1916 -- are legitimately allowed to execute return statements if they have
1917 -- nothing more to do.
1921 -- Attributes related to Ada 2012 iterators
1923 when Attribute_Constant_Indexing
1924 | Attribute_Default_Iterator
1925 | Attribute_Implicit_Dereference
1926 | Attribute_Iterable
1927 | Attribute_Iterator_Element
1928 | Attribute_Variable_Indexing
1932 -- Internal attributes used to deal with Ada 2012 delayed aspects. These
1933 -- were already rejected by the parser. Thus they shouldn't appear here.
1935 when Internal_Attribute_Id =>
1936 raise Program_Error;
1942 when Attribute_Access
1943 | Attribute_Unchecked_Access
1944 | Attribute_Unrestricted_Access
1946 Access_Cases : declare
1947 Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
1948 Btyp_DDT : Entity_Id;
1950 function Enclosing_Object (N : Node_Id) return Node_Id;
1951 -- If N denotes a compound name (selected component, indexed
1952 -- component, or slice), returns the name of the outermost such
1953 -- enclosing object. Otherwise returns N. If the object is a
1954 -- renaming, then the renamed object is returned.
1956 ----------------------
1957 -- Enclosing_Object --
1958 ----------------------
1960 function Enclosing_Object (N : Node_Id) return Node_Id is
1965 while Nkind_In (Obj_Name, N_Selected_Component,
1966 N_Indexed_Component,
1969 Obj_Name := Prefix (Obj_Name);
1972 return Get_Referenced_Object (Obj_Name);
1973 end Enclosing_Object;
1975 -- Local declarations
1977 Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
1979 -- Start of processing for Access_Cases
1982 Btyp_DDT := Designated_Type (Btyp);
1984 -- Handle designated types that come from the limited view
1986 if From_Limited_With (Btyp_DDT)
1987 and then Has_Non_Limited_View (Btyp_DDT)
1989 Btyp_DDT := Non_Limited_View (Btyp_DDT);
1992 -- In order to improve the text of error messages, the designated
1993 -- type of access-to-subprogram itypes is set by the semantics as
1994 -- the associated subprogram entity (see sem_attr). Now we replace
1995 -- such node with the proper E_Subprogram_Type itype.
1997 if Id = Attribute_Unrestricted_Access
1998 and then Is_Subprogram (Directly_Designated_Type (Typ))
2000 -- The following conditions ensure that this special management
2001 -- is done only for "Address!(Prim'Unrestricted_Access)" nodes.
2002 -- At this stage other cases in which the designated type is
2003 -- still a subprogram (instead of an E_Subprogram_Type) are
2004 -- wrong because the semantics must have overridden the type of
2005 -- the node with the type imposed by the context.
2007 if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
2008 and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
2010 Set_Etype (N, RTE (RE_Prim_Ptr));
2014 Subp : constant Entity_Id :=
2015 Directly_Designated_Type (Typ);
2017 Extra : Entity_Id := Empty;
2018 New_Formal : Entity_Id;
2019 Old_Formal : Entity_Id := First_Formal (Subp);
2020 Subp_Typ : Entity_Id;
2023 Subp_Typ := Create_Itype (E_Subprogram_Type, N);
2024 Set_Etype (Subp_Typ, Etype (Subp));
2025 Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
2027 if Present (Old_Formal) then
2028 New_Formal := New_Copy (Old_Formal);
2029 Set_First_Entity (Subp_Typ, New_Formal);
2032 Set_Scope (New_Formal, Subp_Typ);
2033 Etyp := Etype (New_Formal);
2035 -- Handle itypes. There is no need to duplicate
2036 -- here the itypes associated with record types
2037 -- (i.e the implicit full view of private types).
2040 and then Ekind (Base_Type (Etyp)) /= E_Record_Type
2042 Extra := New_Copy (Etyp);
2043 Set_Parent (Extra, New_Formal);
2044 Set_Etype (New_Formal, Extra);
2045 Set_Scope (Extra, Subp_Typ);
2048 Extra := New_Formal;
2049 Next_Formal (Old_Formal);
2050 exit when No (Old_Formal);
2052 Link_Entities (New_Formal, New_Copy (Old_Formal));
2053 Next_Entity (New_Formal);
2056 Unlink_Next_Entity (New_Formal);
2057 Set_Last_Entity (Subp_Typ, Extra);
2060 -- Now that the explicit formals have been duplicated,
2061 -- any extra formals needed by the subprogram must be
2064 if Present (Extra) then
2065 Set_Extra_Formal (Extra, Empty);
2068 Create_Extra_Formals (Subp_Typ);
2069 Set_Directly_Designated_Type (Typ, Subp_Typ);
2074 if Is_Access_Protected_Subprogram_Type (Btyp) then
2075 Expand_Access_To_Protected_Op (N, Pref, Typ);
2077 -- If prefix is a type name, this is a reference to the current
2078 -- instance of the type, within its initialization procedure.
2080 elsif Is_Entity_Name (Pref)
2081 and then Is_Type (Entity (Pref))
2088 -- If the current instance name denotes a task type, then
2089 -- the access attribute is rewritten to be the name of the
2090 -- "_task" parameter associated with the task type's task
2091 -- procedure. An unchecked conversion is applied to ensure
2092 -- a type match in cases of expander-generated calls (e.g.
2095 if Is_Task_Type (Entity (Pref)) then
2097 First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
2098 while Present (Formal) loop
2099 exit when Chars (Formal) = Name_uTask;
2100 Next_Entity (Formal);
2103 pragma Assert (Present (Formal));
2106 Unchecked_Convert_To (Typ,
2107 New_Occurrence_Of (Formal, Loc)));
2110 elsif Is_Protected_Type (Entity (Pref)) then
2112 -- No action needed for current instance located in a
2113 -- component definition (expansion will occur in the
2116 if Is_Protected_Type (Current_Scope) then
2119 -- If the current instance reference is located in a
2120 -- protected subprogram or entry then rewrite the access
2121 -- attribute to be the name of the "_object" parameter.
2122 -- An unchecked conversion is applied to ensure a type
2123 -- match in cases of expander-generated calls (e.g. init
2126 -- The code may be nested in a block, so find enclosing
2127 -- scope that is a protected operation.
2134 Subp := Current_Scope;
2135 while Ekind_In (Subp, E_Loop, E_Block) loop
2136 Subp := Scope (Subp);
2141 (Protected_Body_Subprogram (Subp));
2143 -- For a protected subprogram the _Object parameter
2144 -- is the protected record, so we create an access
2145 -- to it. The _Object parameter of an entry is an
2148 if Ekind (Subp) = E_Entry then
2150 Unchecked_Convert_To (Typ,
2151 New_Occurrence_Of (Formal, Loc)));
2156 Unchecked_Convert_To (Typ,
2157 Make_Attribute_Reference (Loc,
2158 Attribute_Name => Name_Unrestricted_Access,
2160 New_Occurrence_Of (Formal, Loc))));
2161 Analyze_And_Resolve (N);
2166 -- The expression must appear in a default expression,
2167 -- (which in the initialization procedure is the right-hand
2168 -- side of an assignment), and not in a discriminant
2173 while Present (Par) loop
2174 exit when Nkind (Par) = N_Assignment_Statement;
2176 if Nkind (Par) = N_Component_Declaration then
2180 Par := Parent (Par);
2183 if Present (Par) then
2185 Make_Attribute_Reference (Loc,
2186 Prefix => Make_Identifier (Loc, Name_uInit),
2187 Attribute_Name => Attribute_Name (N)));
2189 Analyze_And_Resolve (N, Typ);
2194 -- If the prefix of an Access attribute is a dereference of an
2195 -- access parameter (or a renaming of such a dereference, or a
2196 -- subcomponent of such a dereference) and the context is a
2197 -- general access type (including the type of an object or
2198 -- component with an access_definition, but not the anonymous
2199 -- type of an access parameter or access discriminant), then
2200 -- apply an accessibility check to the access parameter. We used
2201 -- to rewrite the access parameter as a type conversion, but that
2202 -- could only be done if the immediate prefix of the Access
2203 -- attribute was the dereference, and didn't handle cases where
2204 -- the attribute is applied to a subcomponent of the dereference,
2205 -- since there's generally no available, appropriate access type
2206 -- to convert to in that case. The attribute is passed as the
2207 -- point to insert the check, because the access parameter may
2208 -- come from a renaming, possibly in a different scope, and the
2209 -- check must be associated with the attribute itself.
2211 elsif Id = Attribute_Access
2212 and then Nkind (Enc_Object) = N_Explicit_Dereference
2213 and then Is_Entity_Name (Prefix (Enc_Object))
2214 and then (Ekind (Btyp) = E_General_Access_Type
2215 or else Is_Local_Anonymous_Access (Btyp))
2216 and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
2217 and then Ekind (Etype (Entity (Prefix (Enc_Object))))
2218 = E_Anonymous_Access_Type
2219 and then Present (Extra_Accessibility
2220 (Entity (Prefix (Enc_Object))))
2222 Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
2224 -- Ada 2005 (AI-251): If the designated type is an interface we
2225 -- add an implicit conversion to force the displacement of the
2226 -- pointer to reference the secondary dispatch table.
2228 elsif Is_Interface (Btyp_DDT)
2229 and then (Comes_From_Source (N)
2230 or else Comes_From_Source (Ref_Object)
2231 or else (Nkind (Ref_Object) in N_Has_Chars
2232 and then Chars (Ref_Object) = Name_uInit))
2234 if Nkind (Ref_Object) /= N_Explicit_Dereference then
2236 -- No implicit conversion required if types match, or if
2237 -- the prefix is the class_wide_type of the interface. In
2238 -- either case passing an object of the interface type has
2239 -- already set the pointer correctly.
2241 if Btyp_DDT = Etype (Ref_Object)
2242 or else (Is_Class_Wide_Type (Etype (Ref_Object))
2244 Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
2249 Rewrite (Prefix (N),
2250 Convert_To (Btyp_DDT,
2251 New_Copy_Tree (Prefix (N))));
2253 Analyze_And_Resolve (Prefix (N), Btyp_DDT);
2256 -- When the object is an explicit dereference, convert the
2257 -- dereference's prefix.
2261 Obj_DDT : constant Entity_Id :=
2263 (Directly_Designated_Type
2264 (Etype (Prefix (Ref_Object))));
2266 -- No implicit conversion required if designated types
2269 if Obj_DDT /= Btyp_DDT
2270 and then not (Is_Class_Wide_Type (Obj_DDT)
2271 and then Etype (Obj_DDT) = Btyp_DDT)
2275 New_Copy_Tree (Prefix (Ref_Object))));
2276 Analyze_And_Resolve (N, Typ);
2287 -- Transforms 'Adjacent into a call to the floating-point attribute
2288 -- function Adjacent in Fat_xxx (where xxx is the root type)
2290 when Attribute_Adjacent =>
2291 Expand_Fpt_Attribute_RR (N);
2297 when Attribute_Address => Address : declare
2298 Task_Proc : Entity_Id;
2301 -- If the prefix is a task or a task type, the useful address is that
2302 -- of the procedure for the task body, i.e. the actual program unit.
2303 -- We replace the original entity with that of the procedure.
2305 if Is_Entity_Name (Pref)
2306 and then Is_Task_Type (Entity (Pref))
2308 Task_Proc := Next_Entity (Root_Type (Ptyp));
2310 while Present (Task_Proc) loop
2311 exit when Ekind (Task_Proc) = E_Procedure
2312 and then Etype (First_Formal (Task_Proc)) =
2313 Corresponding_Record_Type (Ptyp);
2314 Next_Entity (Task_Proc);
2317 if Present (Task_Proc) then
2318 Set_Entity (Pref, Task_Proc);
2319 Set_Etype (Pref, Etype (Task_Proc));
2322 -- Similarly, the address of a protected operation is the address
2323 -- of the corresponding protected body, regardless of the protected
2324 -- object from which it is selected.
2326 elsif Nkind (Pref) = N_Selected_Component
2327 and then Is_Subprogram (Entity (Selector_Name (Pref)))
2328 and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
2332 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
2334 elsif Nkind (Pref) = N_Explicit_Dereference
2335 and then Ekind (Ptyp) = E_Subprogram_Type
2336 and then Convention (Ptyp) = Convention_Protected
2338 -- The prefix is be a dereference of an access_to_protected_
2339 -- subprogram. The desired address is the second component of
2340 -- the record that represents the access.
2343 Addr : constant Entity_Id := Etype (N);
2344 Ptr : constant Node_Id := Prefix (Pref);
2345 T : constant Entity_Id :=
2346 Equivalent_Type (Base_Type (Etype (Ptr)));
2350 Unchecked_Convert_To (Addr,
2351 Make_Selected_Component (Loc,
2352 Prefix => Unchecked_Convert_To (T, Ptr),
2353 Selector_Name => New_Occurrence_Of (
2354 Next_Entity (First_Entity (T)), Loc))));
2356 Analyze_And_Resolve (N, Addr);
2359 -- Ada 2005 (AI-251): Class-wide interface objects are always
2360 -- "displaced" to reference the tag associated with the interface
2361 -- type. In order to obtain the real address of such objects we
2362 -- generate a call to a run-time subprogram that returns the base
2363 -- address of the object.
2365 -- This processing is not needed in the VM case, where dispatching
2366 -- issues are taken care of by the virtual machine.
2368 elsif Is_Class_Wide_Type (Ptyp)
2369 and then Is_Interface (Underlying_Type (Ptyp))
2370 and then Tagged_Type_Expansion
2371 and then not (Nkind (Pref) in N_Has_Entity
2372 and then Is_Subprogram (Entity (Pref)))
2375 Make_Function_Call (Loc,
2376 Name => New_Occurrence_Of (RTE (RE_Base_Address), Loc),
2377 Parameter_Associations => New_List (
2378 Relocate_Node (N))));
2383 -- Deal with packed array reference, other cases are handled by
2386 if Involves_Packed_Array_Reference (Pref) then
2387 Expand_Packed_Address_Reference (N);
2395 when Attribute_Alignment => Alignment : declare
2399 -- For class-wide types, X'Class'Alignment is transformed into a
2400 -- direct reference to the Alignment of the class type, so that the
2401 -- back end does not have to deal with the X'Class'Alignment
2404 if Is_Entity_Name (Pref)
2405 and then Is_Class_Wide_Type (Entity (Pref))
2407 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
2410 -- For x'Alignment applied to an object of a class wide type,
2411 -- transform X'Alignment into a call to the predefined primitive
2412 -- operation _Alignment applied to X.
2414 elsif Is_Class_Wide_Type (Ptyp) then
2416 Make_Attribute_Reference (Loc,
2418 Attribute_Name => Name_Tag);
2420 New_Node := Build_Get_Alignment (Loc, New_Node);
2422 -- Case where the context is a specific integer type with which
2423 -- the original attribute was compatible. The function has a
2424 -- specific type as well, so to preserve the compatibility we
2425 -- must convert explicitly.
2427 if Typ /= Standard_Integer then
2428 New_Node := Convert_To (Typ, New_Node);
2431 Rewrite (N, New_Node);
2432 Analyze_And_Resolve (N, Typ);
2435 -- For all other cases, we just have to deal with the case of
2436 -- the fact that the result can be universal.
2439 Apply_Universal_Integer_Attribute_Checks (N);
2447 -- We compute this if a packed array reference was present, otherwise we
2448 -- leave the computation up to the back end.
2450 when Attribute_Bit =>
2451 if Involves_Packed_Array_Reference (Pref) then
2452 Expand_Packed_Bit_Reference (N);
2454 Apply_Universal_Integer_Attribute_Checks (N);
2461 -- We compute this if a component clause was present, otherwise we leave
2462 -- the computation up to the back end, since we don't know what layout
2465 -- Note that the attribute can apply to a naked record component
2466 -- in generated code (i.e. the prefix is an identifier that
2467 -- references the component or discriminant entity).
2469 when Attribute_Bit_Position => Bit_Position : declare
2473 if Nkind (Pref) = N_Identifier then
2474 CE := Entity (Pref);
2476 CE := Entity (Selector_Name (Pref));
2479 if Known_Static_Component_Bit_Offset (CE) then
2481 Make_Integer_Literal (Loc,
2482 Intval => Component_Bit_Offset (CE)));
2483 Analyze_And_Resolve (N, Typ);
2486 Apply_Universal_Integer_Attribute_Checks (N);
2494 -- A reference to P'Body_Version or P'Version is expanded to
2497 -- pragma Import (C, Vnn, "uuuuT");
2499 -- Get_Version_String (Vnn)
2501 -- where uuuu is the unit name (dots replaced by double underscore)
2502 -- and T is B for the cases of Body_Version, or Version applied to a
2503 -- subprogram acting as its own spec, and S for Version applied to a
2504 -- subprogram spec or package. This sequence of code references the
2505 -- unsigned constant created in the main program by the binder.
2507 -- A special exception occurs for Standard, where the string returned
2508 -- is a copy of the library string in gnatvsn.ads.
2510 when Attribute_Body_Version
2514 E : constant Entity_Id := Make_Temporary (Loc, 'V');
2519 -- If not library unit, get to containing library unit
2521 Pent := Entity (Pref);
2522 while Pent /= Standard_Standard
2523 and then Scope (Pent) /= Standard_Standard
2524 and then not Is_Child_Unit (Pent)
2526 Pent := Scope (Pent);
2529 -- Special case Standard and Standard.ASCII
2531 if Pent = Standard_Standard or else Pent = Standard_ASCII then
2533 Make_String_Literal (Loc,
2534 Strval => Verbose_Library_Version));
2539 -- Build required string constant
2541 Get_Name_String (Get_Unit_Name (Pent));
2544 for J in 1 .. Name_Len - 2 loop
2545 if Name_Buffer (J) = '.' then
2546 Store_String_Chars ("__");
2548 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
2552 -- Case of subprogram acting as its own spec, always use body
2554 if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
2555 and then Nkind (Parent (Declaration_Node (Pent))) =
2557 and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
2559 Store_String_Chars ("B");
2561 -- Case of no body present, always use spec
2563 elsif not Unit_Requires_Body (Pent) then
2564 Store_String_Chars ("S");
2566 -- Otherwise use B for Body_Version, S for spec
2568 elsif Id = Attribute_Body_Version then
2569 Store_String_Chars ("B");
2571 Store_String_Chars ("S");
2575 Lib.Version_Referenced (S);
2577 -- Insert the object declaration
2579 Insert_Actions (N, New_List (
2580 Make_Object_Declaration (Loc,
2581 Defining_Identifier => E,
2582 Object_Definition =>
2583 New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
2585 -- Set entity as imported with correct external name
2587 Set_Is_Imported (E);
2588 Set_Interface_Name (E, Make_String_Literal (Loc, S));
2590 -- Set entity as internal to ensure proper Sprint output of its
2591 -- implicit importation.
2593 Set_Is_Internal (E);
2595 -- And now rewrite original reference
2598 Make_Function_Call (Loc,
2600 New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
2601 Parameter_Associations => New_List (
2602 New_Occurrence_Of (E, Loc))));
2605 Analyze_And_Resolve (N, RTE (RE_Version_String));
2612 -- Transforms 'Ceiling into a call to the floating-point attribute
2613 -- function Ceiling in Fat_xxx (where xxx is the root type)
2615 when Attribute_Ceiling =>
2616 Expand_Fpt_Attribute_R (N);
2622 -- Transforms 'Callable attribute into a call to the Callable function
2624 when Attribute_Callable =>
2626 -- We have an object of a task interface class-wide type as a prefix
2627 -- to Callable. Generate:
2628 -- callable (Task_Id (Pref._disp_get_task_id));
2630 if Ada_Version >= Ada_2005
2631 and then Ekind (Ptyp) = E_Class_Wide_Type
2632 and then Is_Interface (Ptyp)
2633 and then Is_Task_Interface (Ptyp)
2636 Make_Function_Call (Loc,
2638 New_Occurrence_Of (RTE (RE_Callable), Loc),
2639 Parameter_Associations => New_List (
2640 Make_Unchecked_Type_Conversion (Loc,
2642 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
2643 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
2646 Rewrite (N, Build_Call_With_Task (Pref, RTE (RE_Callable)));
2649 Analyze_And_Resolve (N, Standard_Boolean);
2655 -- Transforms 'Caller attribute into a call to either the
2656 -- Task_Entry_Caller or the Protected_Entry_Caller function.
2658 when Attribute_Caller => Caller : declare
2659 Id_Kind : constant Entity_Id := RTE (RO_AT_Task_Id);
2660 Ent : constant Entity_Id := Entity (Pref);
2661 Conctype : constant Entity_Id := Scope (Ent);
2662 Nest_Depth : Integer := 0;
2669 if Is_Protected_Type (Conctype) then
2670 case Corresponding_Runtime_Package (Conctype) is
2671 when System_Tasking_Protected_Objects_Entries =>
2674 (RTE (RE_Protected_Entry_Caller), Loc);
2676 when System_Tasking_Protected_Objects_Single_Entry =>
2679 (RTE (RE_Protected_Single_Entry_Caller), Loc);
2682 raise Program_Error;
2686 Unchecked_Convert_To (Id_Kind,
2687 Make_Function_Call (Loc,
2689 Parameter_Associations => New_List (
2691 (Find_Protection_Object (Current_Scope), Loc)))));
2696 -- Determine the nesting depth of the E'Caller attribute, that
2697 -- is, how many accept statements are nested within the accept
2698 -- statement for E at the point of E'Caller. The runtime uses
2699 -- this depth to find the specified entry call.
2701 for J in reverse 0 .. Scope_Stack.Last loop
2702 S := Scope_Stack.Table (J).Entity;
2704 -- We should not reach the scope of the entry, as it should
2705 -- already have been checked in Sem_Attr that this attribute
2706 -- reference is within a matching accept statement.
2708 pragma Assert (S /= Conctype);
2713 elsif Is_Entry (S) then
2714 Nest_Depth := Nest_Depth + 1;
2719 Unchecked_Convert_To (Id_Kind,
2720 Make_Function_Call (Loc,
2722 New_Occurrence_Of (RTE (RE_Task_Entry_Caller), Loc),
2723 Parameter_Associations => New_List (
2724 Make_Integer_Literal (Loc,
2725 Intval => Int (Nest_Depth))))));
2728 Analyze_And_Resolve (N, Id_Kind);
2735 -- Transforms 'Compose into a call to the floating-point attribute
2736 -- function Compose in Fat_xxx (where xxx is the root type)
2738 -- Note: we strictly should have special code here to deal with the
2739 -- case of absurdly negative arguments (less than Integer'First)
2740 -- which will return a (signed) zero value, but it hardly seems
2741 -- worth the effort. Absurdly large positive arguments will raise
2742 -- constraint error which is fine.
2744 when Attribute_Compose =>
2745 Expand_Fpt_Attribute_RI (N);
2751 when Attribute_Constrained => Constrained : declare
2752 Formal_Ent : constant Entity_Id := Param_Entity (Pref);
2754 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
2755 -- Ada 2005 (AI-363): Returns True if the object name Obj denotes a
2756 -- view of an aliased object whose subtype is constrained.
2758 ---------------------------------
2759 -- Is_Constrained_Aliased_View --
2760 ---------------------------------
2762 function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
2766 if Is_Entity_Name (Obj) then
2769 if Present (Renamed_Object (E)) then
2770 return Is_Constrained_Aliased_View (Renamed_Object (E));
2772 return Is_Aliased (E) and then Is_Constrained (Etype (E));
2776 return Is_Aliased_View (Obj)
2778 (Is_Constrained (Etype (Obj))
2780 (Nkind (Obj) = N_Explicit_Dereference
2782 not Object_Type_Has_Constrained_Partial_View
2783 (Typ => Base_Type (Etype (Obj)),
2784 Scop => Current_Scope)));
2786 end Is_Constrained_Aliased_View;
2788 -- Start of processing for Constrained
2791 -- Reference to a parameter where the value is passed as an extra
2792 -- actual, corresponding to the extra formal referenced by the
2793 -- Extra_Constrained field of the corresponding formal. If this
2794 -- is an entry in-parameter, it is replaced by a constant renaming
2795 -- for which Extra_Constrained is never created.
2797 if Present (Formal_Ent)
2798 and then Ekind (Formal_Ent) /= E_Constant
2799 and then Present (Extra_Constrained (Formal_Ent))
2803 (Extra_Constrained (Formal_Ent), Sloc (N)));
2805 -- If the prefix is an access to object, the attribute applies to
2806 -- the designated object, so rewrite with an explicit dereference.
2808 elsif Is_Access_Type (Etype (Pref))
2810 (not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
2813 Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
2814 Analyze_And_Resolve (N, Standard_Boolean);
2817 -- For variables with a Extra_Constrained field, we use the
2818 -- corresponding entity.
2820 elsif Nkind (Pref) = N_Identifier
2821 and then Ekind (Entity (Pref)) = E_Variable
2822 and then Present (Extra_Constrained (Entity (Pref)))
2826 (Extra_Constrained (Entity (Pref)), Sloc (N)));
2828 -- For all other entity names, we can tell at compile time
2830 elsif Is_Entity_Name (Pref) then
2832 Ent : constant Entity_Id := Entity (Pref);
2836 -- (RM J.4) obsolescent cases
2838 if Is_Type (Ent) then
2842 if Is_Private_Type (Ent) then
2843 Res := not Has_Discriminants (Ent)
2844 or else Is_Constrained (Ent);
2846 -- It not a private type, must be a generic actual type
2847 -- that corresponded to a private type. We know that this
2848 -- correspondence holds, since otherwise the reference
2849 -- within the generic template would have been illegal.
2852 if Is_Composite_Type (Underlying_Type (Ent)) then
2853 Res := Is_Constrained (Ent);
2860 -- For access type, apply access check as needed
2862 if Is_Access_Type (Ptyp) then
2863 Apply_Access_Check (N);
2866 -- If the prefix is not a variable or is aliased, then
2867 -- definitely true; if it's a formal parameter without an
2868 -- associated extra formal, then treat it as constrained.
2870 -- Ada 2005 (AI-363): An aliased prefix must be known to be
2871 -- constrained in order to set the attribute to True.
2873 if not Is_Variable (Pref)
2874 or else Present (Formal_Ent)
2875 or else (Ada_Version < Ada_2005
2876 and then Is_Aliased_View (Pref))
2877 or else (Ada_Version >= Ada_2005
2878 and then Is_Constrained_Aliased_View (Pref))
2882 -- Variable case, look at type to see if it is constrained.
2883 -- Note that the one case where this is not accurate (the
2884 -- procedure formal case), has been handled above.
2886 -- We use the Underlying_Type here (and below) in case the
2887 -- type is private without discriminants, but the full type
2888 -- has discriminants. This case is illegal, but we generate
2889 -- it internally for passing to the Extra_Constrained
2893 -- In Ada 2012, test for case of a limited tagged type,
2894 -- in which case the attribute is always required to
2895 -- return True. The underlying type is tested, to make
2896 -- sure we also return True for cases where there is an
2897 -- unconstrained object with an untagged limited partial
2898 -- view which has defaulted discriminants (such objects
2899 -- always produce a False in earlier versions of
2900 -- Ada). (Ada 2012: AI05-0214)
2903 Is_Constrained (Underlying_Type (Etype (Ent)))
2905 (Ada_Version >= Ada_2012
2906 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2907 and then Is_Limited_Type (Ptyp));
2911 Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
2914 -- Prefix is not an entity name. These are also cases where we can
2915 -- always tell at compile time by looking at the form and type of the
2916 -- prefix. If an explicit dereference of an object with constrained
2917 -- partial view, this is unconstrained (Ada 2005: AI95-0363). If the
2918 -- underlying type is a limited tagged type, then Constrained is
2919 -- required to always return True (Ada 2012: AI05-0214).
2925 not Is_Variable (Pref)
2927 (Nkind (Pref) = N_Explicit_Dereference
2929 not Object_Type_Has_Constrained_Partial_View
2930 (Typ => Base_Type (Ptyp),
2931 Scop => Current_Scope))
2932 or else Is_Constrained (Underlying_Type (Ptyp))
2933 or else (Ada_Version >= Ada_2012
2934 and then Is_Tagged_Type (Underlying_Type (Ptyp))
2935 and then Is_Limited_Type (Ptyp))),
2939 Analyze_And_Resolve (N, Standard_Boolean);
2946 -- Transforms 'Copy_Sign into a call to the floating-point attribute
2947 -- function Copy_Sign in Fat_xxx (where xxx is the root type)
2949 when Attribute_Copy_Sign =>
2950 Expand_Fpt_Attribute_RR (N);
2956 -- Transforms 'Count attribute into a call to the Count function
2958 when Attribute_Count => Count : declare
2960 Conctyp : Entity_Id;
2962 Entry_Id : Entity_Id;
2967 -- If the prefix is a member of an entry family, retrieve both
2968 -- entry name and index. For a simple entry there is no index.
2970 if Nkind (Pref) = N_Indexed_Component then
2971 Entnam := Prefix (Pref);
2972 Index := First (Expressions (Pref));
2978 Entry_Id := Entity (Entnam);
2980 -- Find the concurrent type in which this attribute is referenced
2981 -- (there had better be one).
2983 Conctyp := Current_Scope;
2984 while not Is_Concurrent_Type (Conctyp) loop
2985 Conctyp := Scope (Conctyp);
2990 if Is_Protected_Type (Conctyp) then
2992 -- No need to transform 'Count into a function call if the current
2993 -- scope has been eliminated. In this case such transformation is
2994 -- also not viable because the enclosing protected object is not
2997 if Is_Eliminated (Current_Scope) then
3001 case Corresponding_Runtime_Package (Conctyp) is
3002 when System_Tasking_Protected_Objects_Entries =>
3003 Name := New_Occurrence_Of (RTE (RE_Protected_Count), Loc);
3006 Make_Function_Call (Loc,
3008 Parameter_Associations => New_List (
3010 (Find_Protection_Object (Current_Scope), Loc),
3011 Entry_Index_Expression
3012 (Loc, Entry_Id, Index, Scope (Entry_Id))));
3014 when System_Tasking_Protected_Objects_Single_Entry =>
3016 New_Occurrence_Of (RTE (RE_Protected_Count_Entry), Loc);
3019 Make_Function_Call (Loc,
3021 Parameter_Associations => New_List (
3023 (Find_Protection_Object (Current_Scope), Loc)));
3026 raise Program_Error;
3033 Make_Function_Call (Loc,
3034 Name => New_Occurrence_Of (RTE (RE_Task_Count), Loc),
3035 Parameter_Associations => New_List (
3036 Entry_Index_Expression (Loc,
3037 Entry_Id, Index, Scope (Entry_Id))));
3040 -- The call returns type Natural but the context is universal integer
3041 -- so any integer type is allowed. The attribute was already resolved
3042 -- so its Etype is the required result type. If the base type of the
3043 -- context type is other than Standard.Integer we put in a conversion
3044 -- to the required type. This can be a normal typed conversion since
3045 -- both input and output types of the conversion are integer types
3047 if Base_Type (Typ) /= Base_Type (Standard_Integer) then
3048 Rewrite (N, Convert_To (Typ, Call));
3053 Analyze_And_Resolve (N, Typ);
3056 ---------------------
3057 -- Descriptor_Size --
3058 ---------------------
3060 when Attribute_Descriptor_Size =>
3062 -- Attribute Descriptor_Size is handled by the back end when applied
3063 -- to an unconstrained array type.
3065 if Is_Array_Type (Ptyp)
3066 and then not Is_Constrained (Ptyp)
3068 Apply_Universal_Integer_Attribute_Checks (N);
3070 -- For any other type, the descriptor size is 0 because there is no
3071 -- actual descriptor, but the result is not formally static.
3074 Rewrite (N, Make_Integer_Literal (Loc, 0));
3076 Set_Is_Static_Expression (N, False);
3083 -- This processing is shared by Elab_Spec
3085 -- What we do is to insert the following declarations
3088 -- pragma Import (C, enn, "name___elabb/s");
3090 -- and then the Elab_Body/Spec attribute is replaced by a reference
3091 -- to this defining identifier.
3093 when Attribute_Elab_Body
3094 | Attribute_Elab_Spec
3096 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3097 -- back-end knows how to handle these attributes directly.
3099 if CodePeer_Mode then
3104 Ent : constant Entity_Id := Make_Temporary (Loc, 'E');
3108 procedure Make_Elab_String (Nod : Node_Id);
3109 -- Given Nod, an identifier, or a selected component, put the
3110 -- image into the current string literal, with double underline
3111 -- between components.
3113 ----------------------
3114 -- Make_Elab_String --
3115 ----------------------
3117 procedure Make_Elab_String (Nod : Node_Id) is
3119 if Nkind (Nod) = N_Selected_Component then
3120 Make_Elab_String (Prefix (Nod));
3121 Store_String_Char ('_');
3122 Store_String_Char ('_');
3123 Get_Name_String (Chars (Selector_Name (Nod)));
3126 pragma Assert (Nkind (Nod) = N_Identifier);
3127 Get_Name_String (Chars (Nod));
3130 Store_String_Chars (Name_Buffer (1 .. Name_Len));
3131 end Make_Elab_String;
3133 -- Start of processing for Elab_Body/Elab_Spec
3136 -- First we need to prepare the string literal for the name of
3137 -- the elaboration routine to be referenced.
3140 Make_Elab_String (Pref);
3141 Store_String_Chars ("___elab");
3142 Lang := Make_Identifier (Loc, Name_C);
3144 if Id = Attribute_Elab_Body then
3145 Store_String_Char ('b');
3147 Store_String_Char ('s');
3152 Insert_Actions (N, New_List (
3153 Make_Subprogram_Declaration (Loc,
3155 Make_Procedure_Specification (Loc,
3156 Defining_Unit_Name => Ent)),
3159 Chars => Name_Import,
3160 Pragma_Argument_Associations => New_List (
3161 Make_Pragma_Argument_Association (Loc, Expression => Lang),
3163 Make_Pragma_Argument_Association (Loc,
3164 Expression => Make_Identifier (Loc, Chars (Ent))),
3166 Make_Pragma_Argument_Association (Loc,
3167 Expression => Make_String_Literal (Loc, Str))))));
3169 Set_Entity (N, Ent);
3170 Rewrite (N, New_Occurrence_Of (Ent, Loc));
3173 --------------------
3174 -- Elab_Subp_Body --
3175 --------------------
3177 -- Always ignored. In CodePeer mode, gnat2scil knows how to handle
3178 -- this attribute directly, and if we are not in CodePeer mode it is
3179 -- entirely ignored ???
3181 when Attribute_Elab_Subp_Body =>
3188 -- Elaborated is always True for preelaborated units, predefined units,
3189 -- pure units and units which have Elaborate_Body pragmas. These units
3190 -- have no elaboration entity.
3192 -- Note: The Elaborated attribute is never passed to the back end
3194 when Attribute_Elaborated => Elaborated : declare
3195 Elab_Id : constant Entity_Id := Elaboration_Entity (Entity (Pref));
3198 if Present (Elab_Id) then
3201 Left_Opnd => New_Occurrence_Of (Elab_Id, Loc),
3202 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)));
3204 Analyze_And_Resolve (N, Typ);
3206 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3214 when Attribute_Enum_Rep => Enum_Rep : declare
3218 -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
3221 if Is_Non_Empty_List (Exprs) then
3222 Expr := First (Exprs);
3227 -- If the expression is an enumeration literal, it is replaced by the
3230 if Nkind (Expr) in N_Has_Entity
3231 and then Ekind (Entity (Expr)) = E_Enumeration_Literal
3234 Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
3236 -- If this is a renaming of a literal, recover the representation
3237 -- of the original. If it renames an expression there is nothing to
3240 elsif Nkind (Expr) in N_Has_Entity
3241 and then Ekind (Entity (Expr)) = E_Constant
3242 and then Present (Renamed_Object (Entity (Expr)))
3243 and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
3244 and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
3245 E_Enumeration_Literal
3248 Make_Integer_Literal (Loc,
3249 Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
3251 -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
3252 -- X'Enum_Rep expands to
3256 -- This is simply a direct conversion from the enumeration type to
3257 -- the target integer type, which is treated by the back end as a
3258 -- normal integer conversion, treating the enumeration type as an
3259 -- integer, which is exactly what we want. We set Conversion_OK to
3260 -- make sure that the analyzer does not complain about what otherwise
3261 -- might be an illegal conversion.
3264 Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
3268 Analyze_And_Resolve (N, Typ);
3275 when Attribute_Enum_Val => Enum_Val : declare
3277 Btyp : constant Entity_Id := Base_Type (Ptyp);
3280 -- X'Enum_Val (Y) expands to
3282 -- [constraint_error when _rep_to_pos (Y, False) = -1, msg]
3285 Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
3287 -- Ensure that the expression is not truncated since the "bad" bits
3290 if Nkind (Expr) = N_Unchecked_Type_Conversion then
3291 Set_No_Truncation (Expr);
3295 Make_Raise_Constraint_Error (Loc,
3299 Make_Function_Call (Loc,
3301 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
3302 Parameter_Associations => New_List (
3303 Relocate_Node (Duplicate_Subexpr (Expr)),
3304 New_Occurrence_Of (Standard_False, Loc))),
3306 Right_Opnd => Make_Integer_Literal (Loc, -1)),
3307 Reason => CE_Range_Check_Failed));
3310 Analyze_And_Resolve (N, Ptyp);
3317 -- Transforms 'Exponent into a call to the floating-point attribute
3318 -- function Exponent in Fat_xxx (where xxx is the root type)
3320 when Attribute_Exponent =>
3321 Expand_Fpt_Attribute_R (N);
3327 -- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
3329 when Attribute_External_Tag =>
3331 Make_Function_Call (Loc,
3333 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3334 Parameter_Associations => New_List (
3335 Make_Attribute_Reference (Loc,
3336 Attribute_Name => Name_Tag,
3337 Prefix => Prefix (N)))));
3339 Analyze_And_Resolve (N, Standard_String);
3341 -----------------------
3342 -- Finalization_Size --
3343 -----------------------
3345 when Attribute_Finalization_Size => Finalization_Size : declare
3346 function Calculate_Header_Size return Node_Id;
3347 -- Generate a runtime call to calculate the size of the hidden header
3348 -- along with any added padding which would precede a heap-allocated
3349 -- object of the prefix type.
3351 ---------------------------
3352 -- Calculate_Header_Size --
3353 ---------------------------
3355 function Calculate_Header_Size return Node_Id is
3358 -- Universal_Integer
3359 -- (Header_Size_With_Padding (Pref'Alignment))
3362 Convert_To (Universal_Integer,
3363 Make_Function_Call (Loc,
3365 New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
3367 Parameter_Associations => New_List (
3368 Make_Attribute_Reference (Loc,
3369 Prefix => New_Copy_Tree (Pref),
3370 Attribute_Name => Name_Alignment))));
3371 end Calculate_Header_Size;
3377 -- Start of Finalization_Size
3380 -- An object of a class-wide type first requires a runtime check to
3381 -- determine whether it is actually controlled or not. Depending on
3382 -- the outcome of this check, the Finalization_Size of the object
3383 -- may be zero or some positive value.
3385 -- In this scenario, Pref'Finalization_Size is expanded into
3387 -- Size : Integer := 0;
3389 -- if Needs_Finalization (Pref'Tag) then
3391 -- Universal_Integer
3392 -- (Header_Size_With_Padding (Pref'Alignment));
3395 -- and the attribute reference is replaced with a reference to Size.
3397 if Is_Class_Wide_Type (Ptyp) then
3398 Size := Make_Temporary (Loc, 'S');
3400 Insert_Actions (N, New_List (
3403 -- Size : Integer := 0;
3405 Make_Object_Declaration (Loc,
3406 Defining_Identifier => Size,
3407 Object_Definition =>
3408 New_Occurrence_Of (Standard_Integer, Loc),
3409 Expression => Make_Integer_Literal (Loc, 0)),
3412 -- if Needs_Finalization (Pref'Tag) then
3414 -- Universal_Integer
3415 -- (Header_Size_With_Padding (Pref'Alignment));
3418 Make_If_Statement (Loc,
3420 Make_Function_Call (Loc,
3422 New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
3424 Parameter_Associations => New_List (
3425 Make_Attribute_Reference (Loc,
3426 Prefix => New_Copy_Tree (Pref),
3427 Attribute_Name => Name_Tag))),
3429 Then_Statements => New_List (
3430 Make_Assignment_Statement (Loc,
3431 Name => New_Occurrence_Of (Size, Loc),
3432 Expression => Calculate_Header_Size)))));
3434 Rewrite (N, New_Occurrence_Of (Size, Loc));
3436 -- The prefix is known to be controlled at compile time. Calculate
3437 -- Finalization_Size by calling function Header_Size_With_Padding.
3439 elsif Needs_Finalization (Ptyp) then
3440 Rewrite (N, Calculate_Header_Size);
3442 -- The prefix is not an object with controlled parts, so its
3443 -- Finalization_Size is zero.
3446 Rewrite (N, Make_Integer_Literal (Loc, 0));
3449 -- Due to cases where the entity type of the attribute is already
3450 -- resolved the rewritten N must get re-resolved to its appropriate
3453 Analyze_And_Resolve (N, Typ);
3454 end Finalization_Size;
3460 when Attribute_First =>
3462 -- If the prefix type is a constrained packed array type which
3463 -- already has a Packed_Array_Impl_Type representation defined, then
3464 -- replace this attribute with a direct reference to 'First of the
3465 -- appropriate index subtype (since otherwise the back end will try
3466 -- to give us the value of 'First for this implementation type).
3468 if Is_Constrained_Packed_Array (Ptyp) then
3470 Make_Attribute_Reference (Loc,
3471 Attribute_Name => Name_First,
3473 New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
3474 Analyze_And_Resolve (N, Typ);
3476 -- For access type, apply access check as needed
3478 elsif Is_Access_Type (Ptyp) then
3479 Apply_Access_Check (N);
3481 -- For scalar type, if low bound is a reference to an entity, just
3482 -- replace with a direct reference. Note that we can only have a
3483 -- reference to a constant entity at this stage, anything else would
3484 -- have already been rewritten.
3486 elsif Is_Scalar_Type (Ptyp) then
3488 Lo : constant Node_Id := Type_Low_Bound (Ptyp);
3490 if Is_Entity_Name (Lo) then
3491 Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc));
3500 -- Compute this if component clause was present, otherwise we leave the
3501 -- computation to be completed in the back-end, since we don't know what
3502 -- layout will be chosen.
3504 when Attribute_First_Bit => First_Bit_Attr : declare
3505 CE : constant Entity_Id := Entity (Selector_Name (Pref));
3508 -- In Ada 2005 (or later) if we have the non-default bit order, then
3509 -- we return the original value as given in the component clause
3510 -- (RM 2005 13.5.2(3/2)).
3512 if Present (Component_Clause (CE))
3513 and then Ada_Version >= Ada_2005
3514 and then Reverse_Bit_Order (Scope (CE))
3517 Make_Integer_Literal (Loc,
3518 Intval => Expr_Value (First_Bit (Component_Clause (CE)))));
3519 Analyze_And_Resolve (N, Typ);
3521 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
3522 -- rewrite with normalized value if we know it statically.
3524 elsif Known_Static_Component_Bit_Offset (CE) then
3526 Make_Integer_Literal (Loc,
3527 Component_Bit_Offset (CE) mod System_Storage_Unit));
3528 Analyze_And_Resolve (N, Typ);
3530 -- Otherwise left to back end, just do universal integer checks
3533 Apply_Universal_Integer_Attribute_Checks (N);
3537 --------------------------------
3538 -- Fixed_Value, Integer_Value --
3539 --------------------------------
3543 -- fixtype'Fixed_Value (integer-value)
3544 -- inttype'Integer_Value (fixed-value)
3548 -- fixtype (integer-value)
3549 -- inttype (fixed-value)
3553 -- We set Conversion_OK on the conversion because we do not want it
3554 -- to go through the fixed-point conversion circuits.
3556 when Attribute_Fixed_Value
3557 | Attribute_Integer_Value
3559 Rewrite (N, OK_Convert_To (Entity (Pref), First (Exprs)));
3561 -- Note that it might appear that a properly analyzed unchecked
3562 -- conversion would be just fine here, but that's not the case,
3563 -- since the full range checks performed by the following calls
3566 Apply_Type_Conversion_Checks (N);
3568 -- Note that Apply_Type_Conversion_Checks only deals with the
3569 -- overflow checks on conversions involving fixed-point types
3570 -- so we must apply range checks manually on them and expand.
3572 Apply_Scalar_Range_Check
3573 (Expression (N), Etype (N), Fixed_Int => True);
3582 -- Transforms 'Floor into a call to the floating-point attribute
3583 -- function Floor in Fat_xxx (where xxx is the root type)
3585 when Attribute_Floor =>
3586 Expand_Fpt_Attribute_R (N);
3592 -- For the fixed-point type Typ:
3598 -- Result_Type (System.Fore (Universal_Real (Type'First)),
3599 -- Universal_Real (Type'Last))
3601 -- Note that we know that the type is a non-static subtype, or Fore
3602 -- would have itself been computed dynamically in Eval_Attribute.
3604 when Attribute_Fore =>
3607 Make_Function_Call (Loc,
3609 New_Occurrence_Of (RTE (RE_Fore), Loc),
3611 Parameter_Associations => New_List (
3612 Convert_To (Universal_Real,
3613 Make_Attribute_Reference (Loc,
3614 Prefix => New_Occurrence_Of (Ptyp, Loc),
3615 Attribute_Name => Name_First)),
3617 Convert_To (Universal_Real,
3618 Make_Attribute_Reference (Loc,
3619 Prefix => New_Occurrence_Of (Ptyp, Loc),
3620 Attribute_Name => Name_Last))))));
3622 Analyze_And_Resolve (N, Typ);
3628 -- Transforms 'Fraction into a call to the floating-point attribute
3629 -- function Fraction in Fat_xxx (where xxx is the root type)
3631 when Attribute_Fraction =>
3632 Expand_Fpt_Attribute_R (N);
3638 when Attribute_From_Any => From_Any : declare
3639 P_Type : constant Entity_Id := Etype (Pref);
3640 Decls : constant List_Id := New_List;
3644 Build_From_Any_Call (P_Type,
3645 Relocate_Node (First (Exprs)),
3647 Insert_Actions (N, Decls);
3648 Analyze_And_Resolve (N, P_Type);
3651 ----------------------
3652 -- Has_Same_Storage --
3653 ----------------------
3655 when Attribute_Has_Same_Storage => Has_Same_Storage : declare
3656 Loc : constant Source_Ptr := Sloc (N);
3658 X : constant Node_Id := Prefix (N);
3659 Y : constant Node_Id := First (Expressions (N));
3664 -- Rhe expressions for their addresses
3668 -- Rhe expressions for their sizes
3671 -- The attribute is expanded as:
3673 -- (X'address = Y'address)
3674 -- and then (X'Size = Y'Size)
3676 -- If both arguments have the same Etype the second conjunct can be
3680 Make_Attribute_Reference (Loc,
3681 Attribute_Name => Name_Address,
3682 Prefix => New_Copy_Tree (X));
3685 Make_Attribute_Reference (Loc,
3686 Attribute_Name => Name_Address,
3687 Prefix => New_Copy_Tree (Y));
3690 Make_Attribute_Reference (Loc,
3691 Attribute_Name => Name_Size,
3692 Prefix => New_Copy_Tree (X));
3695 Make_Attribute_Reference (Loc,
3696 Attribute_Name => Name_Size,
3697 Prefix => New_Copy_Tree (Y));
3699 if Etype (X) = Etype (Y) then
3702 Left_Opnd => X_Addr,
3703 Right_Opnd => Y_Addr));
3709 Left_Opnd => X_Addr,
3710 Right_Opnd => Y_Addr),
3713 Left_Opnd => X_Size,
3714 Right_Opnd => Y_Size)));
3717 Analyze_And_Resolve (N, Standard_Boolean);
3718 end Has_Same_Storage;
3724 -- For an exception returns a reference to the exception data:
3725 -- Exception_Id!(Prefix'Reference)
3727 -- For a task it returns a reference to the _task_id component of
3728 -- corresponding record:
3730 -- taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
3732 -- in Ada.Task_Identification
3734 when Attribute_Identity => Identity : declare
3735 Id_Kind : Entity_Id;
3738 if Ptyp = Standard_Exception_Type then
3739 Id_Kind := RTE (RE_Exception_Id);
3741 if Present (Renamed_Object (Entity (Pref))) then
3742 Set_Entity (Pref, Renamed_Object (Entity (Pref)));
3746 Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
3748 Id_Kind := RTE (RO_AT_Task_Id);
3750 -- If the prefix is a task interface, the Task_Id is obtained
3751 -- dynamically through a dispatching call, as for other task
3752 -- attributes applied to interfaces.
3754 if Ada_Version >= Ada_2005
3755 and then Ekind (Ptyp) = E_Class_Wide_Type
3756 and then Is_Interface (Ptyp)
3757 and then Is_Task_Interface (Ptyp)
3760 Unchecked_Convert_To
3761 (Id_Kind, Build_Disp_Get_Task_Id_Call (Pref)));
3765 Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
3769 Analyze_And_Resolve (N, Id_Kind);
3776 -- Image attribute is handled in separate unit Exp_Imgv
3778 when Attribute_Image =>
3780 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
3781 -- back-end knows how to handle this attribute directly.
3783 if CodePeer_Mode then
3787 Expand_Image_Attribute (N);
3793 -- X'Img is expanded to typ'Image (X), where typ is the type of X
3795 when Attribute_Img =>
3796 Expand_Image_Attribute (N);
3802 when Attribute_Input => Input : declare
3803 P_Type : constant Entity_Id := Entity (Pref);
3804 B_Type : constant Entity_Id := Base_Type (P_Type);
3805 U_Type : constant Entity_Id := Underlying_Type (P_Type);
3806 Strm : constant Node_Id := First (Exprs);
3814 Cntrl : Node_Id := Empty;
3815 -- Value for controlling argument in call. Always Empty except in
3816 -- the dispatching (class-wide type) case, where it is a reference
3817 -- to the dummy object initialized to the right internal tag.
3819 procedure Freeze_Stream_Subprogram (F : Entity_Id);
3820 -- The expansion of the attribute reference may generate a call to
3821 -- a user-defined stream subprogram that is frozen by the call. This
3822 -- can lead to access-before-elaboration problem if the reference
3823 -- appears in an object declaration and the subprogram body has not
3824 -- been seen. The freezing of the subprogram requires special code
3825 -- because it appears in an expanded context where expressions do
3826 -- not freeze their constituents.
3828 ------------------------------
3829 -- Freeze_Stream_Subprogram --
3830 ------------------------------
3832 procedure Freeze_Stream_Subprogram (F : Entity_Id) is
3833 Decl : constant Node_Id := Unit_Declaration_Node (F);
3837 -- If this is user-defined subprogram, the corresponding
3838 -- stream function appears as a renaming-as-body, and the
3839 -- user subprogram must be retrieved by tree traversal.
3842 and then Nkind (Decl) = N_Subprogram_Declaration
3843 and then Present (Corresponding_Body (Decl))
3845 Bod := Corresponding_Body (Decl);
3847 if Nkind (Unit_Declaration_Node (Bod)) =
3848 N_Subprogram_Renaming_Declaration
3850 Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
3853 end Freeze_Stream_Subprogram;
3855 -- Start of processing for Input
3858 -- If no underlying type, we have an error that will be diagnosed
3859 -- elsewhere, so here we just completely ignore the expansion.
3865 -- Stream operations can appear in user code even if the restriction
3866 -- No_Streams is active (for example, when instantiating a predefined
3867 -- container). In that case rewrite the attribute as a Raise to
3868 -- prevent any run-time use.
3870 if Restriction_Active (No_Streams) then
3872 Make_Raise_Program_Error (Sloc (N),
3873 Reason => PE_Stream_Operation_Not_Allowed));
3874 Set_Etype (N, B_Type);
3878 -- If there is a TSS for Input, just call it
3880 Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
3882 if Present (Fname) then
3886 -- If there is a Stream_Convert pragma, use it, we rewrite
3888 -- sourcetyp'Input (stream)
3892 -- sourcetyp (streamread (strmtyp'Input (stream)));
3894 -- where streamread is the given Read function that converts an
3895 -- argument of type strmtyp to type sourcetyp or a type from which
3896 -- it is derived (extra conversion required for the derived case).
3898 Prag := Get_Stream_Convert_Pragma (P_Type);
3900 if Present (Prag) then
3901 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
3902 Rfunc := Entity (Expression (Arg2));
3906 Make_Function_Call (Loc,
3907 Name => New_Occurrence_Of (Rfunc, Loc),
3908 Parameter_Associations => New_List (
3909 Make_Attribute_Reference (Loc,
3912 (Etype (First_Formal (Rfunc)), Loc),
3913 Attribute_Name => Name_Input,
3914 Expressions => Exprs)))));
3916 Analyze_And_Resolve (N, B_Type);
3921 elsif Is_Elementary_Type (U_Type) then
3923 -- A special case arises if we have a defined _Read routine,
3924 -- since in this case we are required to call this routine.
3927 Typ : Entity_Id := P_Type;
3929 if Present (Full_View (Typ)) then
3930 Typ := Full_View (Typ);
3933 if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
3934 Build_Record_Or_Elementary_Input_Function
3935 (Loc, Typ, Decl, Fname, Use_Underlying => False);
3936 Insert_Action (N, Decl);
3938 -- For normal cases, we call the I_xxx routine directly
3941 Rewrite (N, Build_Elementary_Input_Call (N));
3942 Analyze_And_Resolve (N, P_Type);
3949 elsif Is_Array_Type (U_Type) then
3950 Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
3951 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3953 -- Dispatching case with class-wide type
3955 elsif Is_Class_Wide_Type (P_Type) then
3957 -- No need to do anything else compiling under restriction
3958 -- No_Dispatching_Calls. During the semantic analysis we
3959 -- already notified such violation.
3961 if Restriction_Active (No_Dispatching_Calls) then
3966 Rtyp : constant Entity_Id := Root_Type (P_Type);
3968 Expr : Node_Id; -- call to Descendant_Tag
3969 Get_Tag : Node_Id; -- expression to read the 'Tag
3972 -- Read the internal tag (RM 13.13.2(34)) and use it to
3973 -- initialize a dummy tag value. We used to unconditionally
3976 -- Descendant_Tag (String'Input (Strm), P_Type);
3978 -- which turns into a call to String_Input_Blk_IO. However,
3979 -- if the input is malformed, that could try to read an
3980 -- enormous String, causing chaos. So instead we call
3981 -- String_Input_Tag, which does the same thing as
3982 -- String_Input_Blk_IO, except that if the String is
3983 -- absurdly long, it raises an exception.
3985 -- However, if the No_Stream_Optimizations restriction
3986 -- is active, we disable this unnecessary attempt at
3987 -- robustness; we really need to read the string
3988 -- character-by-character.
3990 -- This value is used only to provide a controlling
3991 -- argument for the eventual _Input call. Descendant_Tag is
3992 -- called rather than Internal_Tag to ensure that we have a
3993 -- tag for a type that is descended from the prefix type and
3994 -- declared at the same accessibility level (the exception
3995 -- Tag_Error will be raised otherwise). The level check is
3996 -- required for Ada 2005 because tagged types can be
3997 -- extended in nested scopes (AI-344).
3999 -- Note: we used to generate an explicit declaration of a
4000 -- constant Ada.Tags.Tag object, and use an occurrence of
4001 -- this constant in Cntrl, but this caused a secondary stack
4004 if Restriction_Active (No_Stream_Optimizations) then
4006 Make_Attribute_Reference (Loc,
4008 New_Occurrence_Of (Standard_String, Loc),
4009 Attribute_Name => Name_Input,
4010 Expressions => New_List (
4011 Relocate_Node (Duplicate_Subexpr (Strm))));
4014 Make_Function_Call (Loc,
4017 (RTE (RE_String_Input_Tag), Loc),
4018 Parameter_Associations => New_List (
4019 Relocate_Node (Duplicate_Subexpr (Strm))));
4023 Make_Function_Call (Loc,
4025 New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
4026 Parameter_Associations => New_List (
4028 Make_Attribute_Reference (Loc,
4029 Prefix => New_Occurrence_Of (P_Type, Loc),
4030 Attribute_Name => Name_Tag)));
4032 Set_Etype (Expr, RTE (RE_Tag));
4034 -- Now we need to get the entity for the call, and construct
4035 -- a function call node, where we preset a reference to Dnn
4036 -- as the controlling argument (doing an unchecked convert
4037 -- to the class-wide tagged type to make it look like a real
4040 Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
4041 Cntrl := Unchecked_Convert_To (P_Type, Expr);
4042 Set_Etype (Cntrl, P_Type);
4043 Set_Parent (Cntrl, N);
4046 -- For tagged types, use the primitive Input function
4048 elsif Is_Tagged_Type (U_Type) then
4049 Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
4051 -- All other record type cases, including protected records. The
4052 -- latter only arise for expander generated code for handling
4053 -- shared passive partition access.
4057 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4059 -- Ada 2005 (AI-216): Program_Error is raised executing default
4060 -- implementation of the Input attribute of an unchecked union
4061 -- type if the type lacks default discriminant values.
4063 if Is_Unchecked_Union (Base_Type (U_Type))
4064 and then No (Discriminant_Constraint (U_Type))
4067 Make_Raise_Program_Error (Loc,
4068 Reason => PE_Unchecked_Union_Restriction));
4073 -- Build the type's Input function, passing the subtype rather
4074 -- than its base type, because checks are needed in the case of
4075 -- constrained discriminants (see Ada 2012 AI05-0192).
4077 Build_Record_Or_Elementary_Input_Function
4078 (Loc, U_Type, Decl, Fname);
4079 Insert_Action (N, Decl);
4081 if Nkind (Parent (N)) = N_Object_Declaration
4082 and then Is_Record_Type (U_Type)
4084 -- The stream function may contain calls to user-defined
4085 -- Read procedures for individual components.
4092 Comp := First_Component (U_Type);
4093 while Present (Comp) loop
4095 Find_Stream_Subprogram
4096 (Etype (Comp), TSS_Stream_Read);
4098 if Present (Func) then
4099 Freeze_Stream_Subprogram (Func);
4102 Next_Component (Comp);
4109 -- If we fall through, Fname is the function to be called. The result
4110 -- is obtained by calling the appropriate function, then converting
4111 -- the result. The conversion does a subtype check.
4114 Make_Function_Call (Loc,
4115 Name => New_Occurrence_Of (Fname, Loc),
4116 Parameter_Associations => New_List (
4117 Relocate_Node (Strm)));
4119 Set_Controlling_Argument (Call, Cntrl);
4120 Rewrite (N, Unchecked_Convert_To (P_Type, Call));
4121 Analyze_And_Resolve (N, P_Type);
4123 if Nkind (Parent (N)) = N_Object_Declaration then
4124 Freeze_Stream_Subprogram (Fname);
4132 when Attribute_Invalid_Value =>
4133 Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
4135 -- The value produced may be a conversion of a literal, which must be
4136 -- resolved to establish its proper type.
4138 Analyze_And_Resolve (N);
4144 when Attribute_Last =>
4146 -- If the prefix type is a constrained packed array type which
4147 -- already has a Packed_Array_Impl_Type representation defined, then
4148 -- replace this attribute with a direct reference to 'Last of the
4149 -- appropriate index subtype (since otherwise the back end will try
4150 -- to give us the value of 'Last for this implementation type).
4152 if Is_Constrained_Packed_Array (Ptyp) then
4154 Make_Attribute_Reference (Loc,
4155 Attribute_Name => Name_Last,
4156 Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc)));
4157 Analyze_And_Resolve (N, Typ);
4159 -- For access type, apply access check as needed
4161 elsif Is_Access_Type (Ptyp) then
4162 Apply_Access_Check (N);
4164 -- For scalar type, if low bound is a reference to an entity, just
4165 -- replace with a direct reference. Note that we can only have a
4166 -- reference to a constant entity at this stage, anything else would
4167 -- have already been rewritten.
4169 elsif Is_Scalar_Type (Ptyp) then
4171 Hi : constant Node_Id := Type_High_Bound (Ptyp);
4173 if Is_Entity_Name (Hi) then
4174 Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc));
4183 -- We compute this if a component clause was present, otherwise we leave
4184 -- the computation up to the back end, since we don't know what layout
4187 when Attribute_Last_Bit => Last_Bit_Attr : declare
4188 CE : constant Entity_Id := Entity (Selector_Name (Pref));
4191 -- In Ada 2005 (or later) if we have the non-default bit order, then
4192 -- we return the original value as given in the component clause
4193 -- (RM 2005 13.5.2(3/2)).
4195 if Present (Component_Clause (CE))
4196 and then Ada_Version >= Ada_2005
4197 and then Reverse_Bit_Order (Scope (CE))
4200 Make_Integer_Literal (Loc,
4201 Intval => Expr_Value (Last_Bit (Component_Clause (CE)))));
4202 Analyze_And_Resolve (N, Typ);
4204 -- Otherwise (Ada 83/95 or Ada 2005 or later with default bit order),
4205 -- rewrite with normalized value if we know it statically.
4207 elsif Known_Static_Component_Bit_Offset (CE)
4208 and then Known_Static_Esize (CE)
4211 Make_Integer_Literal (Loc,
4212 Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
4214 Analyze_And_Resolve (N, Typ);
4216 -- Otherwise leave to back end, just apply universal integer checks
4219 Apply_Universal_Integer_Attribute_Checks (N);
4227 -- Transforms 'Leading_Part into a call to the floating-point attribute
4228 -- function Leading_Part in Fat_xxx (where xxx is the root type)
4230 -- Note: strictly, we should generate special case code to deal with
4231 -- absurdly large positive arguments (greater than Integer'Last), which
4232 -- result in returning the first argument unchanged, but it hardly seems
4233 -- worth the effort. We raise constraint error for absurdly negative
4234 -- arguments which is fine.
4236 when Attribute_Leading_Part =>
4237 Expand_Fpt_Attribute_RI (N);
4243 when Attribute_Length => Length : declare
4248 -- Processing for packed array types
4250 if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
4251 Ityp := Get_Index_Subtype (N);
4253 -- If the index type, Ityp, is an enumeration type with holes,
4254 -- then we calculate X'Length explicitly using
4257 -- (0, Ityp'Pos (X'Last (N)) -
4258 -- Ityp'Pos (X'First (N)) + 1);
4260 -- Since the bounds in the template are the representation values
4261 -- and the back end would get the wrong value.
4263 if Is_Enumeration_Type (Ityp)
4264 and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
4269 Xnum := Expr_Value (First (Expressions (N)));
4273 Make_Attribute_Reference (Loc,
4274 Prefix => New_Occurrence_Of (Typ, Loc),
4275 Attribute_Name => Name_Max,
4276 Expressions => New_List
4277 (Make_Integer_Literal (Loc, 0),
4281 Make_Op_Subtract (Loc,
4283 Make_Attribute_Reference (Loc,
4284 Prefix => New_Occurrence_Of (Ityp, Loc),
4285 Attribute_Name => Name_Pos,
4287 Expressions => New_List (
4288 Make_Attribute_Reference (Loc,
4289 Prefix => Duplicate_Subexpr (Pref),
4290 Attribute_Name => Name_Last,
4291 Expressions => New_List (
4292 Make_Integer_Literal (Loc, Xnum))))),
4295 Make_Attribute_Reference (Loc,
4296 Prefix => New_Occurrence_Of (Ityp, Loc),
4297 Attribute_Name => Name_Pos,
4299 Expressions => New_List (
4300 Make_Attribute_Reference (Loc,
4302 Duplicate_Subexpr_No_Checks (Pref),
4303 Attribute_Name => Name_First,
4304 Expressions => New_List (
4305 Make_Integer_Literal (Loc, Xnum)))))),
4307 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4309 Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
4312 -- If the prefix type is a constrained packed array type which
4313 -- already has a Packed_Array_Impl_Type representation defined,
4314 -- then replace this attribute with a reference to 'Range_Length
4315 -- of the appropriate index subtype (since otherwise the
4316 -- back end will try to give us the value of 'Length for
4317 -- this implementation type).s
4319 elsif Is_Constrained (Ptyp) then
4321 Make_Attribute_Reference (Loc,
4322 Attribute_Name => Name_Range_Length,
4323 Prefix => New_Occurrence_Of (Ityp, Loc)));
4324 Analyze_And_Resolve (N, Typ);
4329 elsif Is_Access_Type (Ptyp) then
4330 Apply_Access_Check (N);
4332 -- If the designated type is a packed array type, then we convert
4333 -- the reference to:
4336 -- xtyp'Pos (Pref'Last (Expr)) -
4337 -- xtyp'Pos (Pref'First (Expr)));
4339 -- This is a bit complex, but it is the easiest thing to do that
4340 -- works in all cases including enum types with holes xtyp here
4341 -- is the appropriate index type.
4344 Dtyp : constant Entity_Id := Designated_Type (Ptyp);
4348 if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
4349 Xtyp := Get_Index_Subtype (N);
4352 Make_Attribute_Reference (Loc,
4353 Prefix => New_Occurrence_Of (Typ, Loc),
4354 Attribute_Name => Name_Max,
4355 Expressions => New_List (
4356 Make_Integer_Literal (Loc, 0),
4359 Make_Integer_Literal (Loc, 1),
4360 Make_Op_Subtract (Loc,
4362 Make_Attribute_Reference (Loc,
4363 Prefix => New_Occurrence_Of (Xtyp, Loc),
4364 Attribute_Name => Name_Pos,
4365 Expressions => New_List (
4366 Make_Attribute_Reference (Loc,
4367 Prefix => Duplicate_Subexpr (Pref),
4368 Attribute_Name => Name_Last,
4370 New_Copy_List (Exprs)))),
4373 Make_Attribute_Reference (Loc,
4374 Prefix => New_Occurrence_Of (Xtyp, Loc),
4375 Attribute_Name => Name_Pos,
4376 Expressions => New_List (
4377 Make_Attribute_Reference (Loc,
4379 Duplicate_Subexpr_No_Checks (Pref),
4380 Attribute_Name => Name_First,
4382 New_Copy_List (Exprs)))))))));
4384 Analyze_And_Resolve (N, Typ);
4388 -- Otherwise leave it to the back end
4391 Apply_Universal_Integer_Attribute_Checks (N);
4395 -- Attribute Loop_Entry is replaced with a reference to a constant value
4396 -- which captures the prefix at the entry point of the related loop. The
4397 -- loop itself may be transformed into a conditional block.
4399 when Attribute_Loop_Entry =>
4400 Expand_Loop_Entry_Attribute (N);
4406 -- Transforms 'Machine into a call to the floating-point attribute
4407 -- function Machine in Fat_xxx (where xxx is the root type).
4408 -- Expansion is avoided for cases the back end can handle directly.
4410 when Attribute_Machine =>
4411 if not Is_Inline_Floating_Point_Attribute (N) then
4412 Expand_Fpt_Attribute_R (N);
4415 ----------------------
4416 -- Machine_Rounding --
4417 ----------------------
4419 -- Transforms 'Machine_Rounding into a call to the floating-point
4420 -- attribute function Machine_Rounding in Fat_xxx (where xxx is the root
4421 -- type). Expansion is avoided for cases the back end can handle
4424 when Attribute_Machine_Rounding =>
4425 if not Is_Inline_Floating_Point_Attribute (N) then
4426 Expand_Fpt_Attribute_R (N);
4433 -- Machine_Size is equivalent to Object_Size, so transform it into
4434 -- Object_Size and that way the back end never sees Machine_Size.
4436 when Attribute_Machine_Size =>
4438 Make_Attribute_Reference (Loc,
4439 Prefix => Prefix (N),
4440 Attribute_Name => Name_Object_Size));
4442 Analyze_And_Resolve (N, Typ);
4448 -- The only case that can get this far is the dynamic case of the old
4449 -- Ada 83 Mantissa attribute for the fixed-point case. For this case,
4456 -- ityp (System.Mantissa.Mantissa_Value
4457 -- (Integer'Integer_Value (typ'First),
4458 -- Integer'Integer_Value (typ'Last)));
4460 when Attribute_Mantissa =>
4463 Make_Function_Call (Loc,
4465 New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
4467 Parameter_Associations => New_List (
4468 Make_Attribute_Reference (Loc,
4469 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4470 Attribute_Name => Name_Integer_Value,
4471 Expressions => New_List (
4472 Make_Attribute_Reference (Loc,
4473 Prefix => New_Occurrence_Of (Ptyp, Loc),
4474 Attribute_Name => Name_First))),
4476 Make_Attribute_Reference (Loc,
4477 Prefix => New_Occurrence_Of (Standard_Integer, Loc),
4478 Attribute_Name => Name_Integer_Value,
4479 Expressions => New_List (
4480 Make_Attribute_Reference (Loc,
4481 Prefix => New_Occurrence_Of (Ptyp, Loc),
4482 Attribute_Name => Name_Last)))))));
4484 Analyze_And_Resolve (N, Typ);
4490 when Attribute_Max =>
4491 Expand_Min_Max_Attribute (N);
4493 ----------------------------------
4494 -- Max_Size_In_Storage_Elements --
4495 ----------------------------------
4497 when Attribute_Max_Size_In_Storage_Elements => declare
4498 Typ : constant Entity_Id := Etype (N);
4501 Conversion_Added : Boolean := False;
4502 -- A flag which tracks whether the original attribute has been
4503 -- wrapped inside a type conversion.
4506 -- If the prefix is X'Class, we transform it into a direct reference
4507 -- to the class-wide type, because the back end must not see a 'Class
4508 -- reference. See also 'Size.
4510 if Is_Entity_Name (Pref)
4511 and then Is_Class_Wide_Type (Entity (Pref))
4513 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4517 Apply_Universal_Integer_Attribute_Checks (N);
4519 -- The universal integer check may sometimes add a type conversion,
4520 -- retrieve the original attribute reference from the expression.
4524 if Nkind (Attr) = N_Type_Conversion then
4525 Attr := Expression (Attr);
4526 Conversion_Added := True;
4529 pragma Assert (Nkind (Attr) = N_Attribute_Reference);
4531 -- Heap-allocated controlled objects contain two extra pointers which
4532 -- are not part of the actual type. Transform the attribute reference
4533 -- into a runtime expression to add the size of the hidden header.
4535 if Needs_Finalization (Ptyp)
4536 and then not Header_Size_Added (Attr)
4538 Set_Header_Size_Added (Attr);
4541 -- P'Max_Size_In_Storage_Elements +
4542 -- Universal_Integer
4543 -- (Header_Size_With_Padding (Ptyp'Alignment))
4547 Left_Opnd => Relocate_Node (Attr),
4549 Convert_To (Universal_Integer,
4550 Make_Function_Call (Loc,
4553 (RTE (RE_Header_Size_With_Padding), Loc),
4555 Parameter_Associations => New_List (
4556 Make_Attribute_Reference (Loc,
4558 New_Occurrence_Of (Ptyp, Loc),
4559 Attribute_Name => Name_Alignment))))));
4561 -- Add a conversion to the target type
4563 if not Conversion_Added then
4565 Make_Type_Conversion (Loc,
4566 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4567 Expression => Relocate_Node (Attr)));
4575 --------------------
4576 -- Mechanism_Code --
4577 --------------------
4579 when Attribute_Mechanism_Code =>
4581 -- We must replace the prefix in the renamed case
4583 if Is_Entity_Name (Pref)
4584 and then Present (Alias (Entity (Pref)))
4586 Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
4593 when Attribute_Min =>
4594 Expand_Min_Max_Attribute (N);
4600 when Attribute_Mod => Mod_Case : declare
4601 Arg : constant Node_Id := Relocate_Node (First (Exprs));
4602 Hi : constant Node_Id := Type_High_Bound (Etype (Arg));
4603 Modv : constant Uint := Modulus (Btyp);
4607 -- This is not so simple. The issue is what type to use for the
4608 -- computation of the modular value.
4610 -- The easy case is when the modulus value is within the bounds
4611 -- of the signed integer type of the argument. In this case we can
4612 -- just do the computation in that signed integer type, and then
4613 -- do an ordinary conversion to the target type.
4615 if Modv <= Expr_Value (Hi) then
4620 Right_Opnd => Make_Integer_Literal (Loc, Modv))));
4622 -- Here we know that the modulus is larger than type'Last of the
4623 -- integer type. There are two cases to consider:
4625 -- a) The integer value is non-negative. In this case, it is
4626 -- returned as the result (since it is less than the modulus).
4628 -- b) The integer value is negative. In this case, we know that the
4629 -- result is modulus + value, where the value might be as small as
4630 -- -modulus. The trouble is what type do we use to do the subtract.
4631 -- No type will do, since modulus can be as big as 2**64, and no
4632 -- integer type accommodates this value. Let's do bit of algebra
4635 -- = modulus - (-value)
4636 -- = (modulus - 1) - (-value - 1)
4638 -- Now modulus - 1 is certainly in range of the modular type.
4639 -- -value is in the range 1 .. modulus, so -value -1 is in the
4640 -- range 0 .. modulus-1 which is in range of the modular type.
4641 -- Furthermore, (-value - 1) can be expressed as -(value + 1)
4642 -- which we can compute using the integer base type.
4644 -- Once this is done we analyze the if expression without range
4645 -- checks, because we know everything is in range, and we want
4646 -- to prevent spurious warnings on either branch.
4650 Make_If_Expression (Loc,
4651 Expressions => New_List (
4653 Left_Opnd => Duplicate_Subexpr (Arg),
4654 Right_Opnd => Make_Integer_Literal (Loc, 0)),
4657 Duplicate_Subexpr_No_Checks (Arg)),
4659 Make_Op_Subtract (Loc,
4661 Make_Integer_Literal (Loc,
4662 Intval => Modv - 1),
4668 Left_Opnd => Duplicate_Subexpr_No_Checks (Arg),
4670 Make_Integer_Literal (Loc,
4671 Intval => 1))))))));
4675 Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
4682 -- Transforms 'Model into a call to the floating-point attribute
4683 -- function Model in Fat_xxx (where xxx is the root type).
4684 -- Expansion is avoided for cases the back end can handle directly.
4686 when Attribute_Model =>
4687 if not Is_Inline_Floating_Point_Attribute (N) then
4688 Expand_Fpt_Attribute_R (N);
4695 -- The processing for Object_Size shares the processing for Size
4701 when Attribute_Old => Old : declare
4702 Typ : constant Entity_Id := Etype (N);
4703 CW_Temp : Entity_Id;
4710 -- Generating C code we don't need to expand this attribute when
4711 -- we are analyzing the internally built nested postconditions
4712 -- procedure since it will be expanded inline (and later it will
4713 -- be removed by Expand_N_Subprogram_Body). It this expansion is
4714 -- performed in such case then the compiler generates unreferenced
4715 -- extra temporaries.
4717 if Modify_Tree_For_C
4718 and then Chars (Current_Scope) = Name_uPostconditions
4723 -- Climb the parent chain looking for subprogram _Postconditions
4726 while Present (Subp) loop
4727 exit when Nkind (Subp) = N_Subprogram_Body
4728 and then Chars (Defining_Entity (Subp)) = Name_uPostconditions;
4730 -- If assertions are disabled, no need to create the declaration
4731 -- that preserves the value. The postcondition pragma in which
4732 -- 'Old appears will be checked or disabled according to the
4733 -- current policy in effect.
4735 if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
4739 Subp := Parent (Subp);
4742 -- 'Old can only appear in a postcondition, the generated body of
4743 -- _Postconditions must be in the tree (or inlined if we are
4744 -- generating C code).
4748 or else (Modify_Tree_For_C and then In_Inlined_Body));
4750 Temp := Make_Temporary (Loc, 'T', Pref);
4752 -- Set the entity kind now in order to mark the temporary as a
4753 -- handler of attribute 'Old's prefix.
4755 Set_Ekind (Temp, E_Constant);
4756 Set_Stores_Attribute_Old_Prefix (Temp);
4758 -- Push the scope of the related subprogram where _Postcondition
4759 -- resides as this ensures that the object will be analyzed in the
4762 if Present (Subp) then
4763 Push_Scope (Scope (Defining_Entity (Subp)));
4765 -- No need to push the scope when generating C code since the
4766 -- _Postcondition procedure has been inlined.
4768 else pragma Assert (Modify_Tree_For_C);
4769 pragma Assert (In_Inlined_Body);
4773 -- Locate the insertion place of the internal temporary that saves
4776 if Present (Subp) then
4779 -- Generating C, the postcondition procedure has been inlined and the
4780 -- temporary is added before the first declaration of the enclosing
4783 else pragma Assert (Modify_Tree_For_C);
4785 while Nkind (Ins_Nod) /= N_Subprogram_Body loop
4786 Ins_Nod := Parent (Ins_Nod);
4789 Ins_Nod := First (Declarations (Ins_Nod));
4792 -- Preserve the tag of the prefix by offering a specific view of the
4793 -- class-wide version of the prefix.
4795 if Is_Tagged_Type (Typ) then
4798 -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
4800 CW_Temp := Make_Temporary (Loc, 'T');
4801 CW_Typ := Class_Wide_Type (Typ);
4803 Insert_Before_And_Analyze (Ins_Nod,
4804 Make_Object_Declaration (Loc,
4805 Defining_Identifier => CW_Temp,
4806 Constant_Present => True,
4807 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
4809 Convert_To (CW_Typ, Relocate_Node (Pref))));
4812 -- Temp : Typ renames Typ (CW_Temp);
4814 Insert_Before_And_Analyze (Ins_Nod,
4815 Make_Object_Renaming_Declaration (Loc,
4816 Defining_Identifier => Temp,
4817 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
4819 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
4825 -- Temp : constant Typ := Pref;
4827 Insert_Before_And_Analyze (Ins_Nod,
4828 Make_Object_Declaration (Loc,
4829 Defining_Identifier => Temp,
4830 Constant_Present => True,
4831 Object_Definition => New_Occurrence_Of (Typ, Loc),
4832 Expression => Relocate_Node (Pref)));
4835 if Present (Subp) then
4839 -- Ensure that the prefix of attribute 'Old is valid. The check must
4840 -- be inserted after the expansion of the attribute has taken place
4841 -- to reflect the new placement of the prefix.
4843 if Validity_Checks_On and then Validity_Check_Operands then
4844 Ensure_Valid (Pref);
4847 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4850 ----------------------
4851 -- Overlaps_Storage --
4852 ----------------------
4854 when Attribute_Overlaps_Storage => Overlaps_Storage : declare
4855 Loc : constant Source_Ptr := Sloc (N);
4857 X : constant Node_Id := Prefix (N);
4858 Y : constant Node_Id := First (Expressions (N));
4861 X_Addr, Y_Addr : Node_Id;
4862 -- the expressions for their integer addresses
4864 X_Size, Y_Size : Node_Id;
4865 -- the expressions for their sizes
4870 -- Attribute expands into:
4872 -- if X'Address < Y'address then
4873 -- (X'address + X'Size - 1) >= Y'address
4875 -- (Y'address + Y'size - 1) >= X'Address
4878 -- with the proper address operations. We convert addresses to
4879 -- integer addresses to use predefined arithmetic. The size is
4880 -- expressed in storage units. We add copies of X_Addr and Y_Addr
4881 -- to prevent the appearance of the same node in two places in
4885 Unchecked_Convert_To (RTE (RE_Integer_Address),
4886 Make_Attribute_Reference (Loc,
4887 Attribute_Name => Name_Address,
4888 Prefix => New_Copy_Tree (X)));
4891 Unchecked_Convert_To (RTE (RE_Integer_Address),
4892 Make_Attribute_Reference (Loc,
4893 Attribute_Name => Name_Address,
4894 Prefix => New_Copy_Tree (Y)));
4897 Make_Op_Divide (Loc,
4899 Make_Attribute_Reference (Loc,
4900 Attribute_Name => Name_Size,
4901 Prefix => New_Copy_Tree (X)),
4903 Make_Integer_Literal (Loc, System_Storage_Unit));
4906 Make_Op_Divide (Loc,
4908 Make_Attribute_Reference (Loc,
4909 Attribute_Name => Name_Size,
4910 Prefix => New_Copy_Tree (Y)),
4912 Make_Integer_Literal (Loc, System_Storage_Unit));
4916 Left_Opnd => X_Addr,
4917 Right_Opnd => Y_Addr);
4920 Make_If_Expression (Loc, New_List (
4926 Left_Opnd => New_Copy_Tree (X_Addr),
4928 Make_Op_Subtract (Loc,
4929 Left_Opnd => X_Size,
4930 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4931 Right_Opnd => Y_Addr),
4936 Left_Opnd => New_Copy_Tree (Y_Addr),
4938 Make_Op_Subtract (Loc,
4939 Left_Opnd => Y_Size,
4940 Right_Opnd => Make_Integer_Literal (Loc, 1))),
4941 Right_Opnd => X_Addr))));
4943 Analyze_And_Resolve (N, Standard_Boolean);
4944 end Overlaps_Storage;
4950 when Attribute_Output => Output : declare
4951 P_Type : constant Entity_Id := Entity (Pref);
4952 U_Type : constant Entity_Id := Underlying_Type (P_Type);
4960 -- If no underlying type, we have an error that will be diagnosed
4961 -- elsewhere, so here we just completely ignore the expansion.
4967 -- Stream operations can appear in user code even if the restriction
4968 -- No_Streams is active (for example, when instantiating a predefined
4969 -- container). In that case rewrite the attribute as a Raise to
4970 -- prevent any run-time use.
4972 if Restriction_Active (No_Streams) then
4974 Make_Raise_Program_Error (Sloc (N),
4975 Reason => PE_Stream_Operation_Not_Allowed));
4976 Set_Etype (N, Standard_Void_Type);
4980 -- If TSS for Output is present, just call it
4982 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
4984 if Present (Pname) then
4988 -- If there is a Stream_Convert pragma, use it, we rewrite
4990 -- sourcetyp'Output (stream, Item)
4994 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
4996 -- where strmwrite is the given Write function that converts an
4997 -- argument of type sourcetyp or a type acctyp, from which it is
4998 -- derived to type strmtyp. The conversion to acttyp is required
4999 -- for the derived case.
5001 Prag := Get_Stream_Convert_Pragma (P_Type);
5003 if Present (Prag) then
5005 Next (Next (First (Pragma_Argument_Associations (Prag))));
5006 Wfunc := Entity (Expression (Arg3));
5009 Make_Attribute_Reference (Loc,
5010 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5011 Attribute_Name => Name_Output,
5012 Expressions => New_List (
5013 Relocate_Node (First (Exprs)),
5014 Make_Function_Call (Loc,
5015 Name => New_Occurrence_Of (Wfunc, Loc),
5016 Parameter_Associations => New_List (
5017 OK_Convert_To (Etype (First_Formal (Wfunc)),
5018 Relocate_Node (Next (First (Exprs)))))))));
5023 -- For elementary types, we call the W_xxx routine directly. Note
5024 -- that the effect of Write and Output is identical for the case
5025 -- of an elementary type (there are no discriminants or bounds).
5027 elsif Is_Elementary_Type (U_Type) then
5029 -- A special case arises if we have a defined _Write routine,
5030 -- since in this case we are required to call this routine.
5033 Typ : Entity_Id := P_Type;
5035 if Present (Full_View (Typ)) then
5036 Typ := Full_View (Typ);
5039 if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
5040 Build_Record_Or_Elementary_Output_Procedure
5041 (Loc, Typ, Decl, Pname);
5042 Insert_Action (N, Decl);
5044 -- For normal cases, we call the W_xxx routine directly
5047 Rewrite (N, Build_Elementary_Write_Call (N));
5055 elsif Is_Array_Type (U_Type) then
5056 Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
5057 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5059 -- Class-wide case, first output external tag, then dispatch
5060 -- to the appropriate primitive Output function (RM 13.13.2(31)).
5062 elsif Is_Class_Wide_Type (P_Type) then
5064 -- No need to do anything else compiling under restriction
5065 -- No_Dispatching_Calls. During the semantic analysis we
5066 -- already notified such violation.
5068 if Restriction_Active (No_Dispatching_Calls) then
5073 Strm : constant Node_Id := First (Exprs);
5074 Item : constant Node_Id := Next (Strm);
5077 -- Ada 2005 (AI-344): Check that the accessibility level
5078 -- of the type of the output object is not deeper than
5079 -- that of the attribute's prefix type.
5081 -- if Get_Access_Level (Item'Tag)
5082 -- /= Get_Access_Level (P_Type'Tag)
5087 -- String'Output (Strm, External_Tag (Item'Tag));
5089 -- We cannot figure out a practical way to implement this
5090 -- accessibility check on virtual machines, so we omit it.
5092 if Ada_Version >= Ada_2005
5093 and then Tagged_Type_Expansion
5096 Make_Implicit_If_Statement (N,
5100 Build_Get_Access_Level (Loc,
5101 Make_Attribute_Reference (Loc,
5104 Duplicate_Subexpr (Item,
5106 Attribute_Name => Name_Tag)),
5109 Make_Integer_Literal (Loc,
5110 Type_Access_Level (P_Type))),
5113 New_List (Make_Raise_Statement (Loc,
5115 RTE (RE_Tag_Error), Loc)))));
5119 Make_Attribute_Reference (Loc,
5120 Prefix => New_Occurrence_Of (Standard_String, Loc),
5121 Attribute_Name => Name_Output,
5122 Expressions => New_List (
5123 Relocate_Node (Duplicate_Subexpr (Strm)),
5124 Make_Function_Call (Loc,
5126 New_Occurrence_Of (RTE (RE_External_Tag), Loc),
5127 Parameter_Associations => New_List (
5128 Make_Attribute_Reference (Loc,
5131 (Duplicate_Subexpr (Item, Name_Req => True)),
5132 Attribute_Name => Name_Tag))))));
5135 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
5137 -- Tagged type case, use the primitive Output function
5139 elsif Is_Tagged_Type (U_Type) then
5140 Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
5142 -- All other record type cases, including protected records.
5143 -- The latter only arise for expander generated code for
5144 -- handling shared passive partition access.
5148 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5150 -- Ada 2005 (AI-216): Program_Error is raised when executing
5151 -- the default implementation of the Output attribute of an
5152 -- unchecked union type if the type lacks default discriminant
5155 if Is_Unchecked_Union (Base_Type (U_Type))
5156 and then No (Discriminant_Constraint (U_Type))
5159 Make_Raise_Program_Error (Loc,
5160 Reason => PE_Unchecked_Union_Restriction));
5165 Build_Record_Or_Elementary_Output_Procedure
5166 (Loc, Base_Type (U_Type), Decl, Pname);
5167 Insert_Action (N, Decl);
5171 -- If we fall through, Pname is the name of the procedure to call
5173 Rewrite_Stream_Proc_Call (Pname);
5180 -- For enumeration types with a standard representation, Pos is
5181 -- handled by the back end.
5183 -- For enumeration types, with a non-standard representation we generate
5184 -- a call to the _Rep_To_Pos function created when the type was frozen.
5185 -- The call has the form
5187 -- _rep_to_pos (expr, flag)
5189 -- The parameter flag is True if range checks are enabled, causing
5190 -- Program_Error to be raised if the expression has an invalid
5191 -- representation, and False if range checks are suppressed.
5193 -- For integer types, Pos is equivalent to a simple integer
5194 -- conversion and we rewrite it as such
5196 when Attribute_Pos => Pos : declare
5197 Etyp : Entity_Id := Base_Type (Entity (Pref));
5200 -- Deal with zero/non-zero boolean values
5202 if Is_Boolean_Type (Etyp) then
5203 Adjust_Condition (First (Exprs));
5204 Etyp := Standard_Boolean;
5205 Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
5208 -- Case of enumeration type
5210 if Is_Enumeration_Type (Etyp) then
5212 -- Non-standard enumeration type (generate call)
5214 if Present (Enum_Pos_To_Rep (Etyp)) then
5215 Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
5218 Make_Function_Call (Loc,
5220 New_Occurrence_Of (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5221 Parameter_Associations => Exprs)));
5223 Analyze_And_Resolve (N, Typ);
5225 -- Standard enumeration type (do universal integer check)
5228 Apply_Universal_Integer_Attribute_Checks (N);
5231 -- Deal with integer types (replace by conversion)
5233 elsif Is_Integer_Type (Etyp) then
5234 Rewrite (N, Convert_To (Typ, First (Exprs)));
5235 Analyze_And_Resolve (N, Typ);
5244 -- We compute this if a component clause was present, otherwise we leave
5245 -- the computation up to the back end, since we don't know what layout
5248 when Attribute_Position => Position_Attr : declare
5249 CE : constant Entity_Id := Entity (Selector_Name (Pref));
5252 if Present (Component_Clause (CE)) then
5254 -- In Ada 2005 (or later) if we have the non-default bit order,
5255 -- then we return the original value as given in the component
5256 -- clause (RM 2005 13.5.2(2/2)).
5258 if Ada_Version >= Ada_2005
5259 and then Reverse_Bit_Order (Scope (CE))
5262 Make_Integer_Literal (Loc,
5263 Intval => Expr_Value (Position (Component_Clause (CE)))));
5265 -- Otherwise (Ada 83 or 95, or default bit order specified in
5266 -- later Ada version), return the normalized value.
5270 Make_Integer_Literal (Loc,
5271 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
5274 Analyze_And_Resolve (N, Typ);
5276 -- If back end is doing things, just apply universal integer checks
5279 Apply_Universal_Integer_Attribute_Checks (N);
5287 -- 1. Deal with enumeration types with holes.
5288 -- 2. For floating-point, generate call to attribute function.
5289 -- 3. For other cases, deal with constraint checking.
5291 when Attribute_Pred => Pred : declare
5292 Etyp : constant Entity_Id := Base_Type (Ptyp);
5296 -- For enumeration types with non-standard representations, we
5297 -- expand typ'Pred (x) into
5299 -- Pos_To_Rep (Rep_To_Pos (x) - 1)
5301 -- If the representation is contiguous, we compute instead
5302 -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
5303 -- The conversion function Enum_Pos_To_Rep is defined on the
5304 -- base type, not the subtype, so we have to use the base type
5305 -- explicitly for this and other enumeration attributes.
5307 if Is_Enumeration_Type (Ptyp)
5308 and then Present (Enum_Pos_To_Rep (Etyp))
5310 if Has_Contiguous_Rep (Etyp) then
5312 Unchecked_Convert_To (Ptyp,
5315 Make_Integer_Literal (Loc,
5316 Enumeration_Rep (First_Literal (Ptyp))),
5318 Make_Function_Call (Loc,
5321 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5323 Parameter_Associations =>
5325 Unchecked_Convert_To (Ptyp,
5326 Make_Op_Subtract (Loc,
5328 Unchecked_Convert_To (Standard_Integer,
5329 Relocate_Node (First (Exprs))),
5331 Make_Integer_Literal (Loc, 1))),
5332 Rep_To_Pos_Flag (Ptyp, Loc))))));
5335 -- Add Boolean parameter True, to request program errror if
5336 -- we have a bad representation on our hands. If checks are
5337 -- suppressed, then add False instead
5339 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
5341 Make_Indexed_Component (Loc,
5344 (Enum_Pos_To_Rep (Etyp), Loc),
5345 Expressions => New_List (
5346 Make_Op_Subtract (Loc,
5348 Make_Function_Call (Loc,
5351 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
5352 Parameter_Associations => Exprs),
5353 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
5356 Analyze_And_Resolve (N, Typ);
5358 -- For floating-point, we transform 'Pred into a call to the Pred
5359 -- floating-point attribute function in Fat_xxx (xxx is root type).
5360 -- Note that this function takes care of the overflow case.
5362 elsif Is_Floating_Point_Type (Ptyp) then
5363 Expand_Fpt_Attribute_R (N);
5364 Analyze_And_Resolve (N, Typ);
5366 -- For modular types, nothing to do (no overflow, since wraps)
5368 elsif Is_Modular_Integer_Type (Ptyp) then
5371 -- For other types, if argument is marked as needing a range check or
5372 -- overflow checking is enabled, we must generate a check.
5374 elsif not Overflow_Checks_Suppressed (Ptyp)
5375 or else Do_Range_Check (First (Exprs))
5377 Set_Do_Range_Check (First (Exprs), False);
5378 Expand_Pred_Succ_Attribute (N);
5386 -- Ada 2005 (AI-327): Dynamic ceiling priorities
5388 -- We rewrite X'Priority as the following run-time call:
5390 -- Get_Ceiling (X._Object)
5392 -- Note that although X'Priority is notionally an object, it is quite
5393 -- deliberately not defined as an aliased object in the RM. This means
5394 -- that it works fine to rewrite it as a call, without having to worry
5395 -- about complications that would other arise from X'Priority'Access,
5396 -- which is illegal, because of the lack of aliasing.
5398 when Attribute_Priority => Priority : declare
5400 Conctyp : Entity_Id;
5401 New_Itype : Entity_Id;
5402 Object_Parm : Node_Id;
5404 RT_Subprg_Name : Node_Id;
5407 -- Look for the enclosing concurrent type
5409 Conctyp := Current_Scope;
5410 while not Is_Concurrent_Type (Conctyp) loop
5411 Conctyp := Scope (Conctyp);
5414 pragma Assert (Is_Protected_Type (Conctyp));
5416 -- Generate the actual of the call
5418 Subprg := Current_Scope;
5419 while not Present (Protected_Body_Subprogram (Subprg)) loop
5420 Subprg := Scope (Subprg);
5423 -- Use of 'Priority inside protected entries and barriers (in both
5424 -- cases the type of the first formal of their expanded subprogram
5427 if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
5430 -- In the expansion of protected entries the type of the first
5431 -- formal of the Protected_Body_Subprogram is an Address. In order
5432 -- to reference the _object component we generate:
5434 -- type T is access p__ptTV;
5437 New_Itype := Create_Itype (E_Access_Type, N);
5438 Set_Etype (New_Itype, New_Itype);
5439 Set_Directly_Designated_Type (New_Itype,
5440 Corresponding_Record_Type (Conctyp));
5441 Freeze_Itype (New_Itype, N);
5444 -- T!(O)._object'unchecked_access
5447 Make_Attribute_Reference (Loc,
5449 Make_Selected_Component (Loc,
5451 Unchecked_Convert_To (New_Itype,
5453 (First_Entity (Protected_Body_Subprogram (Subprg)),
5455 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5456 Attribute_Name => Name_Unchecked_Access);
5458 -- Use of 'Priority inside a protected subprogram
5462 Make_Attribute_Reference (Loc,
5464 Make_Selected_Component (Loc,
5467 (First_Entity (Protected_Body_Subprogram (Subprg)),
5469 Selector_Name => Make_Identifier (Loc, Name_uObject)),
5470 Attribute_Name => Name_Unchecked_Access);
5473 -- Select the appropriate run-time subprogram
5475 if Number_Entries (Conctyp) = 0 then
5476 RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
5478 RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
5482 Make_Function_Call (Loc,
5483 Name => RT_Subprg_Name,
5484 Parameter_Associations => New_List (Object_Parm));
5488 -- Avoid the generation of extra checks on the pointer to the
5489 -- protected object.
5491 Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
5498 when Attribute_Range_Length =>
5500 -- The only special processing required is for the case where
5501 -- Range_Length is applied to an enumeration type with holes.
5502 -- In this case we transform
5508 -- X'Pos (X'Last) - X'Pos (X'First) + 1
5510 -- So that the result reflects the proper Pos values instead
5511 -- of the underlying representations.
5513 if Is_Enumeration_Type (Ptyp)
5514 and then Has_Non_Standard_Rep (Ptyp)
5519 Make_Op_Subtract (Loc,
5521 Make_Attribute_Reference (Loc,
5522 Attribute_Name => Name_Pos,
5523 Prefix => New_Occurrence_Of (Ptyp, Loc),
5524 Expressions => New_List (
5525 Make_Attribute_Reference (Loc,
5526 Attribute_Name => Name_Last,
5528 New_Occurrence_Of (Ptyp, Loc)))),
5531 Make_Attribute_Reference (Loc,
5532 Attribute_Name => Name_Pos,
5533 Prefix => New_Occurrence_Of (Ptyp, Loc),
5534 Expressions => New_List (
5535 Make_Attribute_Reference (Loc,
5536 Attribute_Name => Name_First,
5538 New_Occurrence_Of (Ptyp, Loc))))),
5540 Right_Opnd => Make_Integer_Literal (Loc, 1)));
5542 Analyze_And_Resolve (N, Typ);
5544 -- For all other cases, the attribute is handled by the back end, but
5545 -- we need to deal with the case of the range check on a universal
5549 Apply_Universal_Integer_Attribute_Checks (N);
5556 when Attribute_Read => Read : declare
5557 P_Type : constant Entity_Id := Entity (Pref);
5558 B_Type : constant Entity_Id := Base_Type (P_Type);
5559 U_Type : constant Entity_Id := Underlying_Type (P_Type);
5569 -- If no underlying type, we have an error that will be diagnosed
5570 -- elsewhere, so here we just completely ignore the expansion.
5576 -- Stream operations can appear in user code even if the restriction
5577 -- No_Streams is active (for example, when instantiating a predefined
5578 -- container). In that case rewrite the attribute as a Raise to
5579 -- prevent any run-time use.
5581 if Restriction_Active (No_Streams) then
5583 Make_Raise_Program_Error (Sloc (N),
5584 Reason => PE_Stream_Operation_Not_Allowed));
5585 Set_Etype (N, B_Type);
5589 -- The simple case, if there is a TSS for Read, just call it
5591 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
5593 if Present (Pname) then
5597 -- If there is a Stream_Convert pragma, use it, we rewrite
5599 -- sourcetyp'Read (stream, Item)
5603 -- Item := sourcetyp (strmread (strmtyp'Input (Stream)));
5605 -- where strmread is the given Read function that converts an
5606 -- argument of type strmtyp to type sourcetyp or a type from which
5607 -- it is derived. The conversion to sourcetyp is required in the
5610 -- A special case arises if Item is a type conversion in which
5611 -- case, we have to expand to:
5613 -- Itemx := typex (strmread (strmtyp'Input (Stream)));
5615 -- where Itemx is the expression of the type conversion (i.e.
5616 -- the actual object), and typex is the type of Itemx.
5618 Prag := Get_Stream_Convert_Pragma (P_Type);
5620 if Present (Prag) then
5621 Arg2 := Next (First (Pragma_Argument_Associations (Prag)));
5622 Rfunc := Entity (Expression (Arg2));
5623 Lhs := Relocate_Node (Next (First (Exprs)));
5625 OK_Convert_To (B_Type,
5626 Make_Function_Call (Loc,
5627 Name => New_Occurrence_Of (Rfunc, Loc),
5628 Parameter_Associations => New_List (
5629 Make_Attribute_Reference (Loc,
5632 (Etype (First_Formal (Rfunc)), Loc),
5633 Attribute_Name => Name_Input,
5634 Expressions => New_List (
5635 Relocate_Node (First (Exprs)))))));
5637 if Nkind (Lhs) = N_Type_Conversion then
5638 Lhs := Expression (Lhs);
5639 Rhs := Convert_To (Etype (Lhs), Rhs);
5643 Make_Assignment_Statement (Loc,
5645 Expression => Rhs));
5646 Set_Assignment_OK (Lhs);
5650 -- For elementary types, we call the I_xxx routine using the first
5651 -- parameter and then assign the result into the second parameter.
5652 -- We set Assignment_OK to deal with the conversion case.
5654 elsif Is_Elementary_Type (U_Type) then
5660 Lhs := Relocate_Node (Next (First (Exprs)));
5661 Rhs := Build_Elementary_Input_Call (N);
5663 if Nkind (Lhs) = N_Type_Conversion then
5664 Lhs := Expression (Lhs);
5665 Rhs := Convert_To (Etype (Lhs), Rhs);
5668 Set_Assignment_OK (Lhs);
5671 Make_Assignment_Statement (Loc,
5673 Expression => Rhs));
5681 elsif Is_Array_Type (U_Type) then
5682 Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
5683 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5685 -- Tagged type case, use the primitive Read function. Note that
5686 -- this will dispatch in the class-wide case which is what we want
5688 elsif Is_Tagged_Type (U_Type) then
5689 Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
5691 -- All other record type cases, including protected records. The
5692 -- latter only arise for expander generated code for handling
5693 -- shared passive partition access.
5697 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5699 -- Ada 2005 (AI-216): Program_Error is raised when executing
5700 -- the default implementation of the Read attribute of an
5701 -- Unchecked_Union type. We replace the attribute with a
5702 -- raise statement (rather than inserting it before) to handle
5703 -- properly the case of an unchecked union that is a record
5706 if Is_Unchecked_Union (Base_Type (U_Type)) then
5708 Make_Raise_Program_Error (Loc,
5709 Reason => PE_Unchecked_Union_Restriction));
5710 Set_Etype (N, B_Type);
5714 if Has_Discriminants (U_Type)
5716 (Discriminant_Default_Value (First_Discriminant (U_Type)))
5718 Build_Mutable_Record_Read_Procedure
5719 (Loc, Full_Base (U_Type), Decl, Pname);
5721 Build_Record_Read_Procedure
5722 (Loc, Full_Base (U_Type), Decl, Pname);
5725 -- Suppress checks, uninitialized or otherwise invalid
5726 -- data does not cause constraint errors to be raised for
5727 -- a complete record read.
5729 Insert_Action (N, Decl, All_Checks);
5733 Rewrite_Stream_Proc_Call (Pname);
5740 -- Ref is identical to To_Address, see To_Address for processing
5746 -- Transforms 'Remainder into a call to the floating-point attribute
5747 -- function Remainder in Fat_xxx (where xxx is the root type)
5749 when Attribute_Remainder =>
5750 Expand_Fpt_Attribute_RR (N);
5756 -- Transform 'Result into reference to _Result formal. At the point
5757 -- where a legal 'Result attribute is expanded, we know that we are in
5758 -- the context of a _Postcondition function with a _Result parameter.
5760 when Attribute_Result =>
5761 Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
5762 Analyze_And_Resolve (N, Typ);
5768 -- The handling of the Round attribute is quite delicate. The processing
5769 -- in Sem_Attr introduced a conversion to universal real, reflecting the
5770 -- semantics of Round, but we do not want anything to do with universal
5771 -- real at runtime, since this corresponds to using floating-point
5774 -- What we have now is that the Etype of the Round attribute correctly
5775 -- indicates the final result type. The operand of the Round is the
5776 -- conversion to universal real, described above, and the operand of
5777 -- this conversion is the actual operand of Round, which may be the
5778 -- special case of a fixed point multiplication or division (Etype =
5781 -- The exapander will expand first the operand of the conversion, then
5782 -- the conversion, and finally the round attribute itself, since we
5783 -- always work inside out. But we cannot simply process naively in this
5784 -- order. In the semantic world where universal fixed and real really
5785 -- exist and have infinite precision, there is no problem, but in the
5786 -- implementation world, where universal real is a floating-point type,
5787 -- we would get the wrong result.
5789 -- So the approach is as follows. First, when expanding a multiply or
5790 -- divide whose type is universal fixed, we do nothing at all, instead
5791 -- deferring the operation till later.
5793 -- The actual processing is done in Expand_N_Type_Conversion which
5794 -- handles the special case of Round by looking at its parent to see if
5795 -- it is a Round attribute, and if it is, handling the conversion (or
5796 -- its fixed multiply/divide child) in an appropriate manner.
5798 -- This means that by the time we get to expanding the Round attribute
5799 -- itself, the Round is nothing more than a type conversion (and will
5800 -- often be a null type conversion), so we just replace it with the
5801 -- appropriate conversion operation.
5803 when Attribute_Round =>
5805 Convert_To (Etype (N), Relocate_Node (First (Exprs))));
5806 Analyze_And_Resolve (N);
5812 -- Transforms 'Rounding into a call to the floating-point attribute
5813 -- function Rounding in Fat_xxx (where xxx is the root type)
5814 -- Expansion is avoided for cases the back end can handle directly.
5816 when Attribute_Rounding =>
5817 if not Is_Inline_Floating_Point_Attribute (N) then
5818 Expand_Fpt_Attribute_R (N);
5825 -- Transforms 'Scaling into a call to the floating-point attribute
5826 -- function Scaling in Fat_xxx (where xxx is the root type)
5828 when Attribute_Scaling =>
5829 Expand_Fpt_Attribute_RI (N);
5831 -------------------------
5832 -- Simple_Storage_Pool --
5833 -------------------------
5835 when Attribute_Simple_Storage_Pool =>
5837 Make_Type_Conversion (Loc,
5838 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
5839 Expression => New_Occurrence_Of (Entity (N), Loc)));
5840 Analyze_And_Resolve (N, Typ);
5846 when Attribute_Object_Size
5848 | Attribute_Value_Size
5849 | Attribute_VADS_Size
5856 -- Processing for VADS_Size case. Note that this processing
5857 -- removes all traces of VADS_Size from the tree, and completes
5858 -- all required processing for VADS_Size by translating the
5859 -- attribute reference to an appropriate Size or Object_Size
5862 if Id = Attribute_VADS_Size
5863 or else (Use_VADS_Size and then Id = Attribute_Size)
5865 -- If the size is specified, then we simply use the specified
5866 -- size. This applies to both types and objects. The size of an
5867 -- object can be specified in the following ways:
5869 -- An explicit size object is given for an object
5870 -- A component size is specified for an indexed component
5871 -- A component clause is specified for a selected component
5872 -- The object is a component of a packed composite object
5874 -- If the size is specified, then VADS_Size of an object
5876 if (Is_Entity_Name (Pref)
5877 and then Present (Size_Clause (Entity (Pref))))
5879 (Nkind (Pref) = N_Component_Clause
5880 and then (Present (Component_Clause
5881 (Entity (Selector_Name (Pref))))
5882 or else Is_Packed (Etype (Prefix (Pref)))))
5884 (Nkind (Pref) = N_Indexed_Component
5885 and then (Component_Size (Etype (Prefix (Pref))) /= 0
5886 or else Is_Packed (Etype (Prefix (Pref)))))
5888 Set_Attribute_Name (N, Name_Size);
5890 -- Otherwise if we have an object rather than a type, then
5891 -- the VADS_Size attribute applies to the type of the object,
5892 -- rather than the object itself. This is one of the respects
5893 -- in which VADS_Size differs from Size.
5896 if (not Is_Entity_Name (Pref)
5897 or else not Is_Type (Entity (Pref)))
5898 and then (Is_Scalar_Type (Ptyp)
5899 or else Is_Constrained (Ptyp))
5901 Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
5904 -- For a scalar type for which no size was explicitly given,
5905 -- VADS_Size means Object_Size. This is the other respect in
5906 -- which VADS_Size differs from Size.
5908 if Is_Scalar_Type (Ptyp)
5909 and then No (Size_Clause (Ptyp))
5911 Set_Attribute_Name (N, Name_Object_Size);
5913 -- In all other cases, Size and VADS_Size are the sane
5916 Set_Attribute_Name (N, Name_Size);
5921 -- If the prefix is X'Class, transform it into a direct reference
5922 -- to the class-wide type, because the back end must not see a
5923 -- 'Class reference.
5925 if Is_Entity_Name (Pref)
5926 and then Is_Class_Wide_Type (Entity (Pref))
5928 Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
5931 -- For X'Size applied to an object of a class-wide type, transform
5932 -- X'Size into a call to the primitive operation _Size applied to
5935 elsif Is_Class_Wide_Type (Ptyp) then
5937 -- No need to do anything else compiling under restriction
5938 -- No_Dispatching_Calls. During the semantic analysis we
5939 -- already noted this restriction violation.
5941 if Restriction_Active (No_Dispatching_Calls) then
5946 Make_Function_Call (Loc,
5948 New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc),
5949 Parameter_Associations => New_List (Pref));
5951 if Typ /= Standard_Long_Long_Integer then
5953 -- The context is a specific integer type with which the
5954 -- original attribute was compatible. The function has a
5955 -- specific type as well, so to preserve the compatibility
5956 -- we must convert explicitly.
5958 New_Node := Convert_To (Typ, New_Node);
5961 Rewrite (N, New_Node);
5962 Analyze_And_Resolve (N, Typ);
5965 -- Case of known RM_Size of a type
5967 elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
5968 and then Is_Entity_Name (Pref)
5969 and then Is_Type (Entity (Pref))
5970 and then Known_Static_RM_Size (Entity (Pref))
5972 Siz := RM_Size (Entity (Pref));
5974 -- Case of known Esize of a type
5976 elsif Id = Attribute_Object_Size
5977 and then Is_Entity_Name (Pref)
5978 and then Is_Type (Entity (Pref))
5979 and then Known_Static_Esize (Entity (Pref))
5981 Siz := Esize (Entity (Pref));
5983 -- Case of known size of object
5985 elsif Id = Attribute_Size
5986 and then Is_Entity_Name (Pref)
5987 and then Is_Object (Entity (Pref))
5988 and then Known_Esize (Entity (Pref))
5989 and then Known_Static_Esize (Entity (Pref))
5991 Siz := Esize (Entity (Pref));
5993 -- For an array component, we can do Size in the front end if the
5994 -- component_size of the array is set.
5996 elsif Nkind (Pref) = N_Indexed_Component then
5997 Siz := Component_Size (Etype (Prefix (Pref)));
5999 -- For a record component, we can do Size in the front end if
6000 -- there is a component clause, or if the record is packed and the
6001 -- component's size is known at compile time.
6003 elsif Nkind (Pref) = N_Selected_Component then
6005 Rec : constant Entity_Id := Etype (Prefix (Pref));
6006 Comp : constant Entity_Id := Entity (Selector_Name (Pref));
6009 if Present (Component_Clause (Comp)) then
6010 Siz := Esize (Comp);
6012 elsif Is_Packed (Rec) then
6013 Siz := RM_Size (Ptyp);
6016 Apply_Universal_Integer_Attribute_Checks (N);
6021 -- All other cases are handled by the back end
6024 Apply_Universal_Integer_Attribute_Checks (N);
6026 -- If Size is applied to a formal parameter that is of a packed
6027 -- array subtype, then apply Size to the actual subtype.
6029 if Is_Entity_Name (Pref)
6030 and then Is_Formal (Entity (Pref))
6031 and then Is_Array_Type (Ptyp)
6032 and then Is_Packed (Ptyp)
6035 Make_Attribute_Reference (Loc,
6037 New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
6038 Attribute_Name => Name_Size));
6039 Analyze_And_Resolve (N, Typ);
6042 -- If Size applies to a dereference of an access to
6043 -- unconstrained packed array, the back end needs to see its
6044 -- unconstrained nominal type, but also a hint to the actual
6045 -- constrained type.
6047 if Nkind (Pref) = N_Explicit_Dereference
6048 and then Is_Array_Type (Ptyp)
6049 and then not Is_Constrained (Ptyp)
6050 and then Is_Packed (Ptyp)
6052 Set_Actual_Designated_Subtype (Pref,
6053 Get_Actual_Subtype (Pref));
6059 -- Common processing for record and array component case
6061 if Siz /= No_Uint and then Siz /= 0 then
6063 CS : constant Boolean := Comes_From_Source (N);
6066 Rewrite (N, Make_Integer_Literal (Loc, Siz));
6068 -- This integer literal is not a static expression. We do
6069 -- not call Analyze_And_Resolve here, because this would
6070 -- activate the circuit for deciding that a static value
6071 -- was out of range, and we don't want that.
6073 -- So just manually set the type, mark the expression as
6074 -- non-static, and then ensure that the result is checked
6075 -- properly if the attribute comes from source (if it was
6076 -- internally generated, we never need a constraint check).
6079 Set_Is_Static_Expression (N, False);
6082 Apply_Constraint_Check (N, Typ);
6092 when Attribute_Storage_Pool =>
6094 Make_Type_Conversion (Loc,
6095 Subtype_Mark => New_Occurrence_Of (Etype (N), Loc),
6096 Expression => New_Occurrence_Of (Entity (N), Loc)));
6097 Analyze_And_Resolve (N, Typ);
6103 when Attribute_Storage_Size => Storage_Size : declare
6104 Alloc_Op : Entity_Id := Empty;
6108 -- Access type case, always go to the root type
6110 -- The case of access types results in a value of zero for the case
6111 -- where no storage size attribute clause has been given. If a
6112 -- storage size has been given, then the attribute is converted
6113 -- to a reference to the variable used to hold this value.
6115 if Is_Access_Type (Ptyp) then
6116 if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
6118 Make_Attribute_Reference (Loc,
6119 Prefix => New_Occurrence_Of (Typ, Loc),
6120 Attribute_Name => Name_Max,
6121 Expressions => New_List (
6122 Make_Integer_Literal (Loc, 0),
6125 (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
6127 elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
6129 -- If the access type is associated with a simple storage pool
6130 -- object, then attempt to locate the optional Storage_Size
6131 -- function of the simple storage pool type. If not found,
6132 -- then the result will default to zero.
6134 if Present (Get_Rep_Pragma (Root_Type (Ptyp),
6135 Name_Simple_Storage_Pool_Type))
6138 Pool_Type : constant Entity_Id :=
6139 Base_Type (Etype (Entity (N)));
6142 Alloc_Op := Get_Name_Entity_Id (Name_Storage_Size);
6143 while Present (Alloc_Op) loop
6144 if Scope (Alloc_Op) = Scope (Pool_Type)
6145 and then Present (First_Formal (Alloc_Op))
6146 and then Etype (First_Formal (Alloc_Op)) = Pool_Type
6151 Alloc_Op := Homonym (Alloc_Op);
6155 -- In the normal Storage_Pool case, retrieve the primitive
6156 -- function associated with the pool type.
6161 (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
6162 Attribute_Name (N));
6165 -- If Storage_Size wasn't found (can only occur in the simple
6166 -- storage pool case), then simply use zero for the result.
6168 if not Present (Alloc_Op) then
6169 Rewrite (N, Make_Integer_Literal (Loc, 0));
6171 -- Otherwise, rewrite the allocator as a call to pool type's
6172 -- Storage_Size function.
6177 Make_Function_Call (Loc,
6179 New_Occurrence_Of (Alloc_Op, Loc),
6181 Parameter_Associations => New_List (
6183 (Associated_Storage_Pool
6184 (Root_Type (Ptyp)), Loc)))));
6188 Rewrite (N, Make_Integer_Literal (Loc, 0));
6191 Analyze_And_Resolve (N, Typ);
6193 -- For tasks, we retrieve the size directly from the TCB. The
6194 -- size may depend on a discriminant of the type, and therefore
6195 -- can be a per-object expression, so type-level information is
6196 -- not sufficient in general. There are four cases to consider:
6198 -- a) If the attribute appears within a task body, the designated
6199 -- TCB is obtained by a call to Self.
6201 -- b) If the prefix of the attribute is the name of a task object,
6202 -- the designated TCB is the one stored in the corresponding record.
6204 -- c) If the prefix is a task type, the size is obtained from the
6205 -- size variable created for each task type
6207 -- d) If no Storage_Size was specified for the type, there is no
6208 -- size variable, and the value is a system-specific default.
6211 if In_Open_Scopes (Ptyp) then
6213 -- Storage_Size (Self)
6217 Make_Function_Call (Loc,
6219 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6220 Parameter_Associations =>
6222 Make_Function_Call (Loc,
6224 New_Occurrence_Of (RTE (RE_Self), Loc))))));
6226 elsif not Is_Entity_Name (Pref)
6227 or else not Is_Type (Entity (Pref))
6229 -- Storage_Size (Rec (Obj).Size)
6233 Make_Function_Call (Loc,
6235 New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
6236 Parameter_Associations =>
6238 Make_Selected_Component (Loc,
6240 Unchecked_Convert_To (
6241 Corresponding_Record_Type (Ptyp),
6242 New_Copy_Tree (Pref)),
6244 Make_Identifier (Loc, Name_uTask_Id))))));
6246 elsif Present (Storage_Size_Variable (Ptyp)) then
6248 -- Static Storage_Size pragma given for type: retrieve value
6249 -- from its allocated storage variable.
6253 Make_Function_Call (Loc,
6254 Name => New_Occurrence_Of (
6255 RTE (RE_Adjust_Storage_Size), Loc),
6256 Parameter_Associations =>
6259 Storage_Size_Variable (Ptyp), Loc)))));
6261 -- Get system default
6265 Make_Function_Call (Loc,
6268 RTE (RE_Default_Stack_Size), Loc))));
6271 Analyze_And_Resolve (N, Typ);
6279 when Attribute_Stream_Size =>
6281 Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
6282 Analyze_And_Resolve (N, Typ);
6288 -- 1. Deal with enumeration types with holes.
6289 -- 2. For floating-point, generate call to attribute function.
6290 -- 3. For other cases, deal with constraint checking.
6292 when Attribute_Succ => Succ : declare
6293 Etyp : constant Entity_Id := Base_Type (Ptyp);
6296 -- For enumeration types with non-standard representations, we
6297 -- expand typ'Succ (x) into
6299 -- Pos_To_Rep (Rep_To_Pos (x) + 1)
6301 -- If the representation is contiguous, we compute instead
6302 -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
6304 if Is_Enumeration_Type (Ptyp)
6305 and then Present (Enum_Pos_To_Rep (Etyp))
6307 if Has_Contiguous_Rep (Etyp) then
6309 Unchecked_Convert_To (Ptyp,
6312 Make_Integer_Literal (Loc,
6313 Enumeration_Rep (First_Literal (Ptyp))),
6315 Make_Function_Call (Loc,
6318 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6320 Parameter_Associations =>
6322 Unchecked_Convert_To (Ptyp,
6325 Unchecked_Convert_To (Standard_Integer,
6326 Relocate_Node (First (Exprs))),
6328 Make_Integer_Literal (Loc, 1))),
6329 Rep_To_Pos_Flag (Ptyp, Loc))))));
6331 -- Add Boolean parameter True, to request program errror if
6332 -- we have a bad representation on our hands. Add False if
6333 -- checks are suppressed.
6335 Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
6337 Make_Indexed_Component (Loc,
6340 (Enum_Pos_To_Rep (Etyp), Loc),
6341 Expressions => New_List (
6344 Make_Function_Call (Loc,
6347 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6348 Parameter_Associations => Exprs),
6349 Right_Opnd => Make_Integer_Literal (Loc, 1)))));
6352 Analyze_And_Resolve (N, Typ);
6354 -- For floating-point, we transform 'Succ into a call to the Succ
6355 -- floating-point attribute function in Fat_xxx (xxx is root type)
6357 elsif Is_Floating_Point_Type (Ptyp) then
6358 Expand_Fpt_Attribute_R (N);
6359 Analyze_And_Resolve (N, Typ);
6361 -- For modular types, nothing to do (no overflow, since wraps)
6363 elsif Is_Modular_Integer_Type (Ptyp) then
6366 -- For other types, if argument is marked as needing a range check or
6367 -- overflow checking is enabled, we must generate a check.
6369 elsif not Overflow_Checks_Suppressed (Ptyp)
6370 or else Do_Range_Check (First (Exprs))
6372 Set_Do_Range_Check (First (Exprs), False);
6373 Expand_Pred_Succ_Attribute (N);
6381 -- Transforms X'Tag into a direct reference to the tag of X
6383 when Attribute_Tag => Tag : declare
6385 Prefix_Is_Type : Boolean;
6388 if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
6389 Ttyp := Entity (Pref);
6390 Prefix_Is_Type := True;
6393 Prefix_Is_Type := False;
6396 if Is_Class_Wide_Type (Ttyp) then
6397 Ttyp := Root_Type (Ttyp);
6400 Ttyp := Underlying_Type (Ttyp);
6402 -- Ada 2005: The type may be a synchronized tagged type, in which
6403 -- case the tag information is stored in the corresponding record.
6405 if Is_Concurrent_Type (Ttyp) then
6406 Ttyp := Corresponding_Record_Type (Ttyp);
6409 if Prefix_Is_Type then
6411 -- For VMs we leave the type attribute unexpanded because
6412 -- there's not a dispatching table to reference.
6414 if Tagged_Type_Expansion then
6416 Unchecked_Convert_To (RTE (RE_Tag),
6418 (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
6419 Analyze_And_Resolve (N, RTE (RE_Tag));
6422 -- Ada 2005 (AI-251): The use of 'Tag in the sources always
6423 -- references the primary tag of the actual object. If 'Tag is
6424 -- applied to class-wide interface objects we generate code that
6425 -- displaces "this" to reference the base of the object.
6427 elsif Comes_From_Source (N)
6428 and then Is_Class_Wide_Type (Etype (Prefix (N)))
6429 and then Is_Interface (Underlying_Type (Etype (Prefix (N))))
6432 -- (To_Tag_Ptr (Prefix'Address)).all
6434 -- Note that Prefix'Address is recursively expanded into a call
6435 -- to Base_Address (Obj.Tag)
6437 -- Not needed for VM targets, since all handled by the VM
6439 if Tagged_Type_Expansion then
6441 Make_Explicit_Dereference (Loc,
6442 Unchecked_Convert_To (RTE (RE_Tag_Ptr),
6443 Make_Attribute_Reference (Loc,
6444 Prefix => Relocate_Node (Pref),
6445 Attribute_Name => Name_Address))));
6446 Analyze_And_Resolve (N, RTE (RE_Tag));
6451 Make_Selected_Component (Loc,
6452 Prefix => Relocate_Node (Pref),
6454 New_Occurrence_Of (First_Tag_Component (Ttyp), Loc)));
6455 Analyze_And_Resolve (N, RTE (RE_Tag));
6463 -- Transforms 'Terminated attribute into a call to Terminated function
6465 when Attribute_Terminated => Terminated : begin
6467 -- The prefix of Terminated is of a task interface class-wide type.
6469 -- terminated (Task_Id (_disp_get_task_id (Pref)));
6471 if Ada_Version >= Ada_2005
6472 and then Ekind (Ptyp) = E_Class_Wide_Type
6473 and then Is_Interface (Ptyp)
6474 and then Is_Task_Interface (Ptyp)
6477 Make_Function_Call (Loc,
6479 New_Occurrence_Of (RTE (RE_Terminated), Loc),
6480 Parameter_Associations => New_List (
6481 Make_Unchecked_Type_Conversion (Loc,
6483 New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
6484 Expression => Build_Disp_Get_Task_Id_Call (Pref)))));
6486 elsif Restricted_Profile then
6488 Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
6492 Build_Call_With_Task (Pref, RTE (RE_Terminated)));
6495 Analyze_And_Resolve (N, Standard_Boolean);
6502 -- Transforms System'To_Address (X) and System.Address'Ref (X) into
6503 -- unchecked conversion from (integral) type of X to type address. If
6504 -- the To_Address is a static expression, the transformed expression
6505 -- also needs to be static, because we do some legality checks (e.g.
6506 -- for Thread_Local_Storage) after this transformation.
6509 | Attribute_To_Address
6511 To_Address : declare
6512 Is_Static : constant Boolean := Is_Static_Expression (N);
6516 Unchecked_Convert_To (RTE (RE_Address),
6517 Relocate_Node (First (Exprs))));
6518 Set_Is_Static_Expression (N, Is_Static);
6520 Analyze_And_Resolve (N, RTE (RE_Address));
6527 when Attribute_To_Any => To_Any : declare
6528 P_Type : constant Entity_Id := Etype (Pref);
6529 Decls : constant List_Id := New_List;
6535 Relocate_Node (First (Exprs))), Decls));
6536 Insert_Actions (N, Decls);
6537 Analyze_And_Resolve (N, RTE (RE_Any));
6544 -- Transforms 'Truncation into a call to the floating-point attribute
6545 -- function Truncation in Fat_xxx (where xxx is the root type).
6546 -- Expansion is avoided for cases the back end can handle directly.
6548 when Attribute_Truncation =>
6549 if not Is_Inline_Floating_Point_Attribute (N) then
6550 Expand_Fpt_Attribute_R (N);
6557 when Attribute_TypeCode => TypeCode : declare
6558 P_Type : constant Entity_Id := Etype (Pref);
6559 Decls : constant List_Id := New_List;
6561 Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
6562 Insert_Actions (N, Decls);
6563 Analyze_And_Resolve (N, RTE (RE_TypeCode));
6566 -----------------------
6567 -- Unbiased_Rounding --
6568 -----------------------
6570 -- Transforms 'Unbiased_Rounding into a call to the floating-point
6571 -- attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
6572 -- root type). Expansion is avoided for cases the back end can handle
6575 when Attribute_Unbiased_Rounding =>
6576 if not Is_Inline_Floating_Point_Attribute (N) then
6577 Expand_Fpt_Attribute_R (N);
6584 when Attribute_Update =>
6585 Expand_Update_Attribute (N);
6591 -- The processing for VADS_Size is shared with Size
6597 -- For enumeration types with a standard representation, and for all
6598 -- other types, Val is handled by the back end. For enumeration types
6599 -- with a non-standard representation we use the _Pos_To_Rep array that
6600 -- was created when the type was frozen.
6602 when Attribute_Val => Val : declare
6603 Etyp : constant Entity_Id := Base_Type (Entity (Pref));
6606 if Is_Enumeration_Type (Etyp)
6607 and then Present (Enum_Pos_To_Rep (Etyp))
6609 if Has_Contiguous_Rep (Etyp) then
6611 Rep_Node : constant Node_Id :=
6612 Unchecked_Convert_To (Etyp,
6615 Make_Integer_Literal (Loc,
6616 Enumeration_Rep (First_Literal (Etyp))),
6618 (Convert_To (Standard_Integer,
6619 Relocate_Node (First (Exprs))))));
6623 Unchecked_Convert_To (Etyp,
6626 Make_Integer_Literal (Loc,
6627 Enumeration_Rep (First_Literal (Etyp))),
6629 Make_Function_Call (Loc,
6632 (TSS (Etyp, TSS_Rep_To_Pos), Loc),
6633 Parameter_Associations => New_List (
6635 Rep_To_Pos_Flag (Etyp, Loc))))));
6640 Make_Indexed_Component (Loc,
6641 Prefix => New_Occurrence_Of (Enum_Pos_To_Rep (Etyp), Loc),
6642 Expressions => New_List (
6643 Convert_To (Standard_Integer,
6644 Relocate_Node (First (Exprs))))));
6647 Analyze_And_Resolve (N, Typ);
6649 -- If the argument is marked as requiring a range check then generate
6652 elsif Do_Range_Check (First (Exprs)) then
6653 Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
6661 -- The code for valid is dependent on the particular types involved.
6662 -- See separate sections below for the generated code in each case.
6664 when Attribute_Valid => Valid : declare
6665 Btyp : Entity_Id := Base_Type (Ptyp);
6667 Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
6668 -- Save the validity checking mode. We always turn off validity
6669 -- checking during process of 'Valid since this is one place
6670 -- where we do not want the implicit validity checks to interfere
6671 -- with the explicit validity check that the programmer is doing.
6673 function Make_Range_Test return Node_Id;
6674 -- Build the code for a range test of the form
6675 -- Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
6677 ---------------------
6678 -- Make_Range_Test --
6679 ---------------------
6681 function Make_Range_Test return Node_Id is
6685 -- The prefix of attribute 'Valid should always denote an object
6686 -- reference. The reference is either coming directly from source
6687 -- or is produced by validity check expansion. The object may be
6688 -- wrapped in a conversion in which case the call to Unqual_Conv
6691 -- If the prefix denotes a variable which captures the value of
6692 -- an object for validation purposes, use the variable in the
6693 -- range test. This ensures that no extra copies or extra reads
6694 -- are produced as part of the test. Generate:
6696 -- Temp : ... := Object;
6697 -- if not Temp in ... then
6699 if Is_Validation_Variable_Reference (Pref) then
6700 Temp := New_Occurrence_Of (Entity (Unqual_Conv (Pref)), Loc);
6702 -- Otherwise the prefix is either a source object or a constant
6703 -- produced by validity check expansion. Generate:
6705 -- Temp : constant ... := Pref;
6706 -- if not Temp in ... then
6709 Temp := Duplicate_Subexpr (Pref);
6714 Left_Opnd => Unchecked_Convert_To (Btyp, Temp),
6718 Unchecked_Convert_To (Btyp,
6719 Make_Attribute_Reference (Loc,
6720 Prefix => New_Occurrence_Of (Ptyp, Loc),
6721 Attribute_Name => Name_First)),
6723 Unchecked_Convert_To (Btyp,
6724 Make_Attribute_Reference (Loc,
6725 Prefix => New_Occurrence_Of (Ptyp, Loc),
6726 Attribute_Name => Name_Last))));
6727 end Make_Range_Test;
6733 -- Start of processing for Attribute_Valid
6736 -- Do not expand sourced code 'Valid reference in CodePeer mode,
6737 -- will be handled by the back-end directly.
6739 if CodePeer_Mode and then Comes_From_Source (N) then
6743 -- Turn off validity checks. We do not want any implicit validity
6744 -- checks to intefere with the explicit check from the attribute
6746 Validity_Checks_On := False;
6748 -- Retrieve the base type. Handle the case where the base type is a
6749 -- private enumeration type.
6751 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then
6752 Btyp := Full_View (Btyp);
6755 -- Floating-point case. This case is handled by the Valid attribute
6756 -- code in the floating-point attribute run-time library.
6758 if Is_Floating_Point_Type (Ptyp) then
6759 Float_Valid : declare
6763 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id;
6764 -- Return entity for Pkg.Nam
6766 --------------------
6767 -- Get_Fat_Entity --
6768 --------------------
6770 function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is
6771 Exp_Name : constant Node_Id :=
6772 Make_Selected_Component (Loc,
6773 Prefix => New_Occurrence_Of (RTE (Pkg), Loc),
6774 Selector_Name => Make_Identifier (Loc, Nam));
6776 Find_Selected_Component (Exp_Name);
6777 return Entity (Exp_Name);
6780 -- Start of processing for Float_Valid
6783 -- The C and AAMP back-ends handle Valid for fpt types
6785 if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
6786 Analyze_And_Resolve (Pref, Ptyp);
6787 Set_Etype (N, Standard_Boolean);
6791 Find_Fat_Info (Ptyp, Ftp, Pkg);
6793 -- If the prefix is a reverse SSO component, or is possibly
6794 -- unaligned, first create a temporary copy that is in
6795 -- native SSO, and properly aligned. Make it Volatile to
6796 -- prevent folding in the back-end. Note that we use an
6797 -- intermediate constrained string type to initialize the
6798 -- temporary, as the value at hand might be invalid, and in
6799 -- that case it cannot be copied using a floating point
6802 if In_Reverse_Storage_Order_Object (Pref)
6803 or else Is_Possibly_Unaligned_Object (Pref)
6806 Temp : constant Entity_Id :=
6807 Make_Temporary (Loc, 'F');
6809 Fat_S : constant Entity_Id :=
6810 Get_Fat_Entity (Name_S);
6811 -- Constrained string subtype of appropriate size
6813 Fat_P : constant Entity_Id :=
6814 Get_Fat_Entity (Name_P);
6817 Decl : constant Node_Id :=
6818 Make_Object_Declaration (Loc,
6819 Defining_Identifier => Temp,
6820 Aliased_Present => True,
6821 Object_Definition =>
6822 New_Occurrence_Of (Ptyp, Loc));
6825 Set_Aspect_Specifications (Decl, New_List (
6826 Make_Aspect_Specification (Loc,
6828 Make_Identifier (Loc, Name_Volatile))));
6834 Make_Assignment_Statement (Loc,
6836 Make_Explicit_Dereference (Loc,
6838 Unchecked_Convert_To (Fat_P,
6839 Make_Attribute_Reference (Loc,
6841 New_Occurrence_Of (Temp, Loc),
6843 Name_Unrestricted_Access))),
6845 Unchecked_Convert_To (Fat_S,
6846 Relocate_Node (Pref)))),
6848 Suppress => All_Checks);
6850 Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
6854 -- We now have an object of the proper endianness and
6855 -- alignment, and can construct a Valid attribute.
6857 -- We make sure the prefix of this valid attribute is
6858 -- marked as not coming from source, to avoid losing
6859 -- warnings from 'Valid looking like a possible update.
6861 Set_Comes_From_Source (Pref, False);
6863 Expand_Fpt_Attribute
6864 (N, Pkg, Name_Valid,
6866 Make_Attribute_Reference (Loc,
6867 Prefix => Unchecked_Convert_To (Ftp, Pref),
6868 Attribute_Name => Name_Unrestricted_Access)));
6871 -- One more task, we still need a range check. Required
6872 -- only if we have a constraint, since the Valid routine
6873 -- catches infinities properly (infinities are never valid).
6875 -- The way we do the range check is simply to create the
6876 -- expression: Valid (N) and then Base_Type(Pref) in Typ.
6878 if not Subtypes_Statically_Match (Ptyp, Btyp) then
6881 Left_Opnd => Relocate_Node (N),
6884 Left_Opnd => Convert_To (Btyp, Pref),
6885 Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
6889 -- Enumeration type with holes
6891 -- For enumeration types with holes, the Pos value constructed by
6892 -- the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
6893 -- second argument of False returns minus one for an invalid value,
6894 -- and the non-negative pos value for a valid value, so the
6895 -- expansion of X'Valid is simply:
6897 -- type(X)'Pos (X) >= 0
6899 -- We can't quite generate it that way because of the requirement
6900 -- for the non-standard second argument of False in the resulting
6901 -- rep_to_pos call, so we have to explicitly create:
6903 -- _rep_to_pos (X, False) >= 0
6905 -- If we have an enumeration subtype, we also check that the
6906 -- value is in range:
6908 -- _rep_to_pos (X, False) >= 0
6910 -- (X >= type(X)'First and then type(X)'Last <= X)
6912 elsif Is_Enumeration_Type (Ptyp)
6913 and then Present (Enum_Pos_To_Rep (Btyp))
6918 Make_Function_Call (Loc,
6920 New_Occurrence_Of (TSS (Btyp, TSS_Rep_To_Pos), Loc),
6921 Parameter_Associations => New_List (
6923 New_Occurrence_Of (Standard_False, Loc))),
6924 Right_Opnd => Make_Integer_Literal (Loc, 0));
6928 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
6930 Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
6932 -- The call to Make_Range_Test will create declarations
6933 -- that need a proper insertion point, but Pref is now
6934 -- attached to a node with no ancestor. Attach to tree
6935 -- even if it is to be rewritten below.
6937 Set_Parent (Tst, Parent (N));
6941 Left_Opnd => Make_Range_Test,
6947 -- Fortran convention booleans
6949 -- For the very special case of Fortran convention booleans, the
6950 -- value is always valid, since it is an integer with the semantics
6951 -- that non-zero is true, and any value is permissible.
6953 elsif Is_Boolean_Type (Ptyp)
6954 and then Convention (Ptyp) = Convention_Fortran
6956 Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
6958 -- For biased representations, we will be doing an unchecked
6959 -- conversion without unbiasing the result. That means that the range
6960 -- test has to take this into account, and the proper form of the
6963 -- Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
6965 elsif Has_Biased_Representation (Ptyp) then
6966 Btyp := RTE (RE_Unsigned_32);
6970 Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
6972 Unchecked_Convert_To (Btyp,
6973 Make_Attribute_Reference (Loc,
6974 Prefix => New_Occurrence_Of (Ptyp, Loc),
6975 Attribute_Name => Name_Range_Length))));
6977 -- For all other scalar types, what we want logically is a
6980 -- X in type(X)'First .. type(X)'Last
6982 -- But that's precisely what won't work because of possible
6983 -- unwanted optimization (and indeed the basic motivation for
6984 -- the Valid attribute is exactly that this test does not work).
6985 -- What will work is:
6987 -- Btyp!(X) >= Btyp!(type(X)'First)
6989 -- Btyp!(X) <= Btyp!(type(X)'Last)
6991 -- where Btyp is an integer type large enough to cover the full
6992 -- range of possible stored values (i.e. it is chosen on the basis
6993 -- of the size of the type, not the range of the values). We write
6994 -- this as two tests, rather than a range check, so that static
6995 -- evaluation will easily remove either or both of the checks if
6996 -- they can be -statically determined to be true (this happens
6997 -- when the type of X is static and the range extends to the full
6998 -- range of stored values).
7000 -- Unsigned types. Note: it is safe to consider only whether the
7001 -- subtype is unsigned, since we will in that case be doing all
7002 -- unsigned comparisons based on the subtype range. Since we use the
7003 -- actual subtype object size, this is appropriate.
7005 -- For example, if we have
7007 -- subtype x is integer range 1 .. 200;
7008 -- for x'Object_Size use 8;
7010 -- Now the base type is signed, but objects of this type are bits
7011 -- unsigned, and doing an unsigned test of the range 1 to 200 is
7012 -- correct, even though a value greater than 127 looks signed to a
7013 -- signed comparison.
7015 elsif Is_Unsigned_Type (Ptyp) then
7016 if Esize (Ptyp) <= 32 then
7017 Btyp := RTE (RE_Unsigned_32);
7019 Btyp := RTE (RE_Unsigned_64);
7022 Rewrite (N, Make_Range_Test);
7027 if Esize (Ptyp) <= Esize (Standard_Integer) then
7028 Btyp := Standard_Integer;
7030 Btyp := Universal_Integer;
7033 Rewrite (N, Make_Range_Test);
7036 -- If a predicate is present, then we do the predicate test, even if
7037 -- within the predicate function (infinite recursion is warned about
7038 -- in Sem_Attr in that case).
7041 Pred_Func : constant Entity_Id := Predicate_Function (Ptyp);
7044 if Present (Pred_Func) then
7047 Left_Opnd => Relocate_Node (N),
7048 Right_Opnd => Make_Predicate_Call (Ptyp, Pref)));
7052 Analyze_And_Resolve (N, Standard_Boolean);
7053 Validity_Checks_On := Save_Validity_Checks_On;
7060 when Attribute_Valid_Scalars => Valid_Scalars : declare
7061 Val_Typ : constant Entity_Id := Validated_View (Ptyp);
7062 Comp_Typ : Entity_Id;
7066 -- Assume that the prefix does not need validation
7070 -- Attribute 'Valid_Scalars is not supported on private tagged types
7072 if Is_Private_Type (Ptyp) and then Is_Tagged_Type (Ptyp) then
7075 -- Attribute 'Valid_Scalars evaluates to True when the type lacks
7078 elsif not Scalar_Part_Present (Val_Typ) then
7081 -- Attribute 'Valid_Scalars is the same as attribute 'Valid when the
7082 -- validated type is a scalar type. Generate:
7084 -- Val_Typ (Pref)'Valid
7086 elsif Is_Scalar_Type (Val_Typ) then
7088 Make_Attribute_Reference (Loc,
7090 Unchecked_Convert_To (Val_Typ, New_Copy_Tree (Pref)),
7091 Attribute_Name => Name_Valid);
7093 -- Validate the scalar components of an array by iterating over all
7094 -- dimensions of the array while checking individual components.
7096 elsif Is_Array_Type (Val_Typ) then
7097 Comp_Typ := Validated_View (Component_Type (Val_Typ));
7099 if Scalar_Part_Present (Comp_Typ) then
7101 Make_Function_Call (Loc,
7104 (Build_Array_VS_Func
7107 Array_Typ => Val_Typ,
7108 Comp_Typ => Comp_Typ),
7110 Parameter_Associations => New_List (Pref));
7113 -- Validate the scalar components, discriminants of a record type by
7114 -- examining the structure of a record type.
7116 elsif Is_Record_Type (Val_Typ) then
7118 Make_Function_Call (Loc,
7121 (Build_Record_VS_Func
7124 Rec_Typ => Val_Typ),
7126 Parameter_Associations => New_List (Pref));
7129 -- Default the attribute to True when the type of the prefix does not
7133 Expr := New_Occurrence_Of (Standard_True, Loc);
7137 Analyze_And_Resolve (N, Standard_Boolean);
7138 Set_Is_Static_Expression (N, False);
7145 -- Value attribute is handled in separate unit Exp_Imgv
7147 when Attribute_Value =>
7148 Exp_Imgv.Expand_Value_Attribute (N);
7154 -- The processing for Value_Size shares the processing for Size
7160 -- The processing for Version shares the processing for Body_Version
7166 -- Wide_Image attribute is handled in separate unit Exp_Imgv
7168 when Attribute_Wide_Image =>
7169 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7170 -- back-end knows how to handle this attribute directly.
7172 if CodePeer_Mode then
7176 Exp_Imgv.Expand_Wide_Image_Attribute (N);
7178 ---------------------
7179 -- Wide_Wide_Image --
7180 ---------------------
7182 -- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
7184 when Attribute_Wide_Wide_Image =>
7185 -- Leave attribute unexpanded in CodePeer mode: the gnat2scil
7186 -- back-end knows how to handle this attribute directly.
7188 if CodePeer_Mode then
7192 Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
7198 -- We expand typ'Wide_Value (X) into
7201 -- (Wide_String_To_String (X, Wide_Character_Encoding_Method))
7203 -- Wide_String_To_String is a runtime function that converts its wide
7204 -- string argument to String, converting any non-translatable characters
7205 -- into appropriate escape sequences. This preserves the required
7206 -- semantics of Wide_Value in all cases, and results in a very simple
7207 -- implementation approach.
7209 -- Note: for this approach to be fully standard compliant for the cases
7210 -- where typ is Wide_Character and Wide_Wide_Character, the encoding
7211 -- method must cover the entire character range (e.g. UTF-8). But that
7212 -- is a reasonable requirement when dealing with encoded character
7213 -- sequences. Presumably if one of the restrictive encoding mechanisms
7214 -- is in use such as Shift-JIS, then characters that cannot be
7215 -- represented using this encoding will not appear in any case.
7217 when Attribute_Wide_Value =>
7219 Make_Attribute_Reference (Loc,
7221 Attribute_Name => Name_Value,
7223 Expressions => New_List (
7224 Make_Function_Call (Loc,
7226 New_Occurrence_Of (RTE (RE_Wide_String_To_String), Loc),
7228 Parameter_Associations => New_List (
7229 Relocate_Node (First (Exprs)),
7230 Make_Integer_Literal (Loc,
7231 Intval => Int (Wide_Character_Encoding_Method)))))));
7233 Analyze_And_Resolve (N, Typ);
7235 ---------------------
7236 -- Wide_Wide_Value --
7237 ---------------------
7239 -- We expand typ'Wide_Value_Value (X) into
7242 -- (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
7244 -- Wide_Wide_String_To_String is a runtime function that converts its
7245 -- wide string argument to String, converting any non-translatable
7246 -- characters into appropriate escape sequences. This preserves the
7247 -- required semantics of Wide_Wide_Value in all cases, and results in a
7248 -- very simple implementation approach.
7250 -- It's not quite right where typ = Wide_Wide_Character, because the
7251 -- encoding method may not cover the whole character type ???
7253 when Attribute_Wide_Wide_Value =>
7255 Make_Attribute_Reference (Loc,
7257 Attribute_Name => Name_Value,
7259 Expressions => New_List (
7260 Make_Function_Call (Loc,
7263 (RTE (RE_Wide_Wide_String_To_String), Loc),
7265 Parameter_Associations => New_List (
7266 Relocate_Node (First (Exprs)),
7267 Make_Integer_Literal (Loc,
7268 Intval => Int (Wide_Character_Encoding_Method)))))));
7270 Analyze_And_Resolve (N, Typ);
7272 ---------------------
7273 -- Wide_Wide_Width --
7274 ---------------------
7276 -- Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
7278 when Attribute_Wide_Wide_Width =>
7279 Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
7285 -- Wide_Width attribute is handled in separate unit Exp_Imgv
7287 when Attribute_Wide_Width =>
7288 Exp_Imgv.Expand_Width_Attribute (N, Wide);
7294 -- Width attribute is handled in separate unit Exp_Imgv
7296 when Attribute_Width =>
7297 Exp_Imgv.Expand_Width_Attribute (N, Normal);
7303 when Attribute_Write => Write : declare
7304 P_Type : constant Entity_Id := Entity (Pref);
7305 U_Type : constant Entity_Id := Underlying_Type (P_Type);
7313 -- If no underlying type, we have an error that will be diagnosed
7314 -- elsewhere, so here we just completely ignore the expansion.
7320 -- Stream operations can appear in user code even if the restriction
7321 -- No_Streams is active (for example, when instantiating a predefined
7322 -- container). In that case rewrite the attribute as a Raise to
7323 -- prevent any run-time use.
7325 if Restriction_Active (No_Streams) then
7327 Make_Raise_Program_Error (Sloc (N),
7328 Reason => PE_Stream_Operation_Not_Allowed));
7329 Set_Etype (N, U_Type);
7333 -- The simple case, if there is a TSS for Write, just call it
7335 Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
7337 if Present (Pname) then
7341 -- If there is a Stream_Convert pragma, use it, we rewrite
7343 -- sourcetyp'Output (stream, Item)
7347 -- strmtyp'Output (Stream, strmwrite (acttyp (Item)));
7349 -- where strmwrite is the given Write function that converts an
7350 -- argument of type sourcetyp or a type acctyp, from which it is
7351 -- derived to type strmtyp. The conversion to acttyp is required
7352 -- for the derived case.
7354 Prag := Get_Stream_Convert_Pragma (P_Type);
7356 if Present (Prag) then
7358 Next (Next (First (Pragma_Argument_Associations (Prag))));
7359 Wfunc := Entity (Expression (Arg3));
7362 Make_Attribute_Reference (Loc,
7363 Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
7364 Attribute_Name => Name_Output,
7365 Expressions => New_List (
7366 Relocate_Node (First (Exprs)),
7367 Make_Function_Call (Loc,
7368 Name => New_Occurrence_Of (Wfunc, Loc),
7369 Parameter_Associations => New_List (
7370 OK_Convert_To (Etype (First_Formal (Wfunc)),
7371 Relocate_Node (Next (First (Exprs)))))))));
7376 -- For elementary types, we call the W_xxx routine directly
7378 elsif Is_Elementary_Type (U_Type) then
7379 Rewrite (N, Build_Elementary_Write_Call (N));
7385 elsif Is_Array_Type (U_Type) then
7386 Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
7387 Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
7389 -- Tagged type case, use the primitive Write function. Note that
7390 -- this will dispatch in the class-wide case which is what we want
7392 elsif Is_Tagged_Type (U_Type) then
7393 Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
7395 -- All other record type cases, including protected records.
7396 -- The latter only arise for expander generated code for
7397 -- handling shared passive partition access.
7401 (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
7403 -- Ada 2005 (AI-216): Program_Error is raised when executing
7404 -- the default implementation of the Write attribute of an
7405 -- Unchecked_Union type. However, if the 'Write reference is
7406 -- within the generated Output stream procedure, Write outputs
7407 -- the components, and the default values of the discriminant
7408 -- are streamed by the Output procedure itself. If there are
7409 -- no default values this is also erroneous.
7411 if Is_Unchecked_Union (Base_Type (U_Type)) then
7412 if (not Is_TSS (Current_Scope, TSS_Stream_Output)
7413 and not Is_TSS (Current_Scope, TSS_Stream_Write))
7414 or else No (Discriminant_Default_Value
7415 (First_Discriminant (U_Type)))
7418 Make_Raise_Program_Error (Loc,
7419 Reason => PE_Unchecked_Union_Restriction));
7420 Set_Etype (N, U_Type);
7425 if Has_Discriminants (U_Type)
7427 (Discriminant_Default_Value (First_Discriminant (U_Type)))
7429 Build_Mutable_Record_Write_Procedure
7430 (Loc, Full_Base (U_Type), Decl, Pname);
7432 Build_Record_Write_Procedure
7433 (Loc, Full_Base (U_Type), Decl, Pname);
7436 Insert_Action (N, Decl);
7440 -- If we fall through, Pname is the procedure to be called
7442 Rewrite_Stream_Proc_Call (Pname);
7445 -- Component_Size is handled by the back end, unless the component size
7446 -- is known at compile time, which is always true in the packed array
7447 -- case. It is important that the packed array case is handled in the
7448 -- front end (see Eval_Attribute) since the back end would otherwise get
7449 -- confused by the equivalent packed array type.
7451 when Attribute_Component_Size =>
7454 -- The following attributes are handled by the back end (except that
7455 -- static cases have already been evaluated during semantic processing,
7456 -- but in any case the back end should not count on this).
7458 -- The back end also handles the non-class-wide cases of Size
7460 when Attribute_Bit_Order
7461 | Attribute_Code_Address
7462 | Attribute_Definite
7464 | Attribute_Null_Parameter
7465 | Attribute_Passed_By_Reference
7466 | Attribute_Pool_Address
7467 | Attribute_Scalar_Storage_Order
7471 -- The following attributes are also handled by the back end, but return
7472 -- a universal integer result, so may need a conversion for checking
7473 -- that the result is in range.
7476 | Attribute_Max_Alignment_For_Allocation
7478 Apply_Universal_Integer_Attribute_Checks (N);
7480 -- The following attributes should not appear at this stage, since they
7481 -- have already been handled by the analyzer (and properly rewritten
7482 -- with corresponding values or entities to represent the right values)
7484 when Attribute_Abort_Signal
7485 | Attribute_Address_Size
7486 | Attribute_Atomic_Always_Lock_Free
7489 | Attribute_Compiler_Version
7490 | Attribute_Default_Bit_Order
7491 | Attribute_Default_Scalar_Storage_Order
7498 | Attribute_Fast_Math
7499 | Attribute_First_Valid
7500 | Attribute_Has_Access_Values
7501 | Attribute_Has_Discriminants
7502 | Attribute_Has_Tagged_Values
7504 | Attribute_Last_Valid
7505 | Attribute_Library_Level
7506 | Attribute_Lock_Free
7507 | Attribute_Machine_Emax
7508 | Attribute_Machine_Emin
7509 | Attribute_Machine_Mantissa
7510 | Attribute_Machine_Overflows
7511 | Attribute_Machine_Radix
7512 | Attribute_Machine_Rounds
7513 | Attribute_Maximum_Alignment
7514 | Attribute_Model_Emin
7515 | Attribute_Model_Epsilon
7516 | Attribute_Model_Mantissa
7517 | Attribute_Model_Small
7519 | Attribute_Partition_ID
7521 | Attribute_Restriction_Set
7522 | Attribute_Safe_Emax
7523 | Attribute_Safe_First
7524 | Attribute_Safe_Large
7525 | Attribute_Safe_Last
7526 | Attribute_Safe_Small
7528 | Attribute_Signed_Zeros
7530 | Attribute_Storage_Unit
7531 | Attribute_Stub_Type
7532 | Attribute_System_Allocator_Alignment
7533 | Attribute_Target_Name
7534 | Attribute_Type_Class
7535 | Attribute_Type_Key
7536 | Attribute_Unconstrained_Array
7537 | Attribute_Universal_Literal_String
7538 | Attribute_Wchar_T_Size
7539 | Attribute_Word_Size
7541 raise Program_Error;
7543 -- The Asm_Input and Asm_Output attributes are not expanded at this
7544 -- stage, but will be eliminated in the expansion of the Asm call, see
7545 -- Exp_Intr for details. So the back end will never see these either.
7547 when Attribute_Asm_Input
7548 | Attribute_Asm_Output
7553 -- Note: as mentioned earlier, individual sections of the above case
7554 -- statement assume there is no code after the case statement, and are
7555 -- legitimately allowed to execute return statements if they have nothing
7556 -- more to do, so DO NOT add code at this point.
7559 when RE_Not_Available =>
7561 end Expand_N_Attribute_Reference;
7563 --------------------------------
7564 -- Expand_Pred_Succ_Attribute --
7565 --------------------------------
7567 -- For typ'Pred (exp), we generate the check
7569 -- [constraint_error when exp = typ'Base'First]
7571 -- Similarly, for typ'Succ (exp), we generate the check
7573 -- [constraint_error when exp = typ'Base'Last]
7575 -- These checks are not generated for modular types, since the proper
7576 -- semantics for Succ and Pred on modular types is to wrap, not raise CE.
7577 -- We also suppress these checks if we are the right side of an assignment
7578 -- statement or the expression of an object declaration, where the flag
7579 -- Suppress_Assignment_Checks is set for the assignment/declaration.
7581 procedure Expand_Pred_Succ_Attribute (N : Node_Id) is
7582 Loc : constant Source_Ptr := Sloc (N);
7583 P : constant Node_Id := Parent (N);
7587 if Attribute_Name (N) = Name_Pred then
7593 if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
7594 or else not Suppress_Assignment_Checks (P)
7597 Make_Raise_Constraint_Error (Loc,
7601 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
7603 Make_Attribute_Reference (Loc,
7605 New_Occurrence_Of (Base_Type (Etype (Prefix (N))), Loc),
7606 Attribute_Name => Cnam)),
7607 Reason => CE_Overflow_Check_Failed));
7609 end Expand_Pred_Succ_Attribute;
7611 -----------------------------
7612 -- Expand_Update_Attribute --
7613 -----------------------------
7615 procedure Expand_Update_Attribute (N : Node_Id) is
7616 procedure Process_Component_Or_Element_Update
7621 -- Generate the statements necessary to update a single component or an
7622 -- element of the prefix. The code is inserted before the attribute N.
7623 -- Temp denotes the entity of the anonymous object created to reflect
7624 -- the changes in values. Comp is the component/index expression to be
7625 -- updated. Expr is an expression yielding the new value of Comp. Typ
7626 -- is the type of the prefix of attribute Update.
7628 procedure Process_Range_Update
7633 -- Generate the statements necessary to update a slice of the prefix.
7634 -- The code is inserted before the attribute N. Temp denotes the entity
7635 -- of the anonymous object created to reflect the changes in values.
7636 -- Comp is range of the slice to be updated. Expr is an expression
7637 -- yielding the new value of Comp. Typ is the type of the prefix of
7638 -- attribute Update.
7640 -----------------------------------------
7641 -- Process_Component_Or_Element_Update --
7642 -----------------------------------------
7644 procedure Process_Component_Or_Element_Update
7650 Loc : constant Source_Ptr := Sloc (Comp);
7655 -- An array element may be modified by the following relations
7656 -- depending on the number of dimensions:
7658 -- 1 => Expr -- one dimensional update
7659 -- (1, ..., N) => Expr -- multi dimensional update
7661 -- The above forms are converted in assignment statements where the
7662 -- left hand side is an indexed component:
7664 -- Temp (1) := Expr; -- one dimensional update
7665 -- Temp (1, ..., N) := Expr; -- multi dimensional update
7667 if Is_Array_Type (Typ) then
7669 -- The index expressions of a multi dimensional array update
7670 -- appear as an aggregate.
7672 if Nkind (Comp) = N_Aggregate then
7673 Exprs := New_Copy_List_Tree (Expressions (Comp));
7675 Exprs := New_List (Relocate_Node (Comp));
7679 Make_Indexed_Component (Loc,
7680 Prefix => New_Occurrence_Of (Temp, Loc),
7681 Expressions => Exprs);
7683 -- A record component update appears in the following form:
7687 -- The above relation is transformed into an assignment statement
7688 -- where the left hand side is a selected component:
7690 -- Temp.Comp := Expr;
7692 else pragma Assert (Is_Record_Type (Typ));
7694 Make_Selected_Component (Loc,
7695 Prefix => New_Occurrence_Of (Temp, Loc),
7696 Selector_Name => Relocate_Node (Comp));
7700 Make_Assignment_Statement (Loc,
7702 Expression => Relocate_Node (Expr)));
7703 end Process_Component_Or_Element_Update;
7705 --------------------------
7706 -- Process_Range_Update --
7707 --------------------------
7709 procedure Process_Range_Update
7715 Index_Typ : constant Entity_Id := Etype (First_Index (Typ));
7716 Loc : constant Source_Ptr := Sloc (Comp);
7720 -- A range update appears as
7722 -- (Low .. High => Expr)
7724 -- The above construct is transformed into a loop that iterates over
7725 -- the given range and modifies the corresponding array values to the
7728 -- for Index in Low .. High loop
7729 -- Temp (<Index_Typ> (Index)) := Expr;
7732 Index := Make_Temporary (Loc, 'I');
7735 Make_Loop_Statement (Loc,
7737 Make_Iteration_Scheme (Loc,
7738 Loop_Parameter_Specification =>
7739 Make_Loop_Parameter_Specification (Loc,
7740 Defining_Identifier => Index,
7741 Discrete_Subtype_Definition => Relocate_Node (Comp))),
7743 Statements => New_List (
7744 Make_Assignment_Statement (Loc,
7746 Make_Indexed_Component (Loc,
7747 Prefix => New_Occurrence_Of (Temp, Loc),
7748 Expressions => New_List (
7749 Convert_To (Index_Typ,
7750 New_Occurrence_Of (Index, Loc)))),
7751 Expression => Relocate_Node (Expr))),
7753 End_Label => Empty));
7754 end Process_Range_Update;
7758 Aggr : constant Node_Id := First (Expressions (N));
7759 Loc : constant Source_Ptr := Sloc (N);
7760 Pref : constant Node_Id := Prefix (N);
7761 Typ : constant Entity_Id := Etype (Pref);
7764 CW_Temp : Entity_Id;
7769 -- Start of processing for Expand_Update_Attribute
7772 -- Create the anonymous object to store the value of the prefix and
7773 -- capture subsequent changes in value.
7775 Temp := Make_Temporary (Loc, 'T', Pref);
7777 -- Preserve the tag of the prefix by offering a specific view of the
7778 -- class-wide version of the prefix.
7780 if Is_Tagged_Type (Typ) then
7783 -- CW_Temp : Typ'Class := Typ'Class (Pref);
7785 CW_Temp := Make_Temporary (Loc, 'T');
7786 CW_Typ := Class_Wide_Type (Typ);
7789 Make_Object_Declaration (Loc,
7790 Defining_Identifier => CW_Temp,
7791 Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
7793 Convert_To (CW_Typ, Relocate_Node (Pref))));
7796 -- Temp : Typ renames Typ (CW_Temp);
7799 Make_Object_Renaming_Declaration (Loc,
7800 Defining_Identifier => Temp,
7801 Subtype_Mark => New_Occurrence_Of (Typ, Loc),
7803 Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc))));
7809 -- Temp : Typ := Pref;
7812 Make_Object_Declaration (Loc,
7813 Defining_Identifier => Temp,
7814 Object_Definition => New_Occurrence_Of (Typ, Loc),
7815 Expression => Relocate_Node (Pref)));
7818 -- Process the update aggregate
7820 Assoc := First (Component_Associations (Aggr));
7821 while Present (Assoc) loop
7822 Comp := First (Choices (Assoc));
7823 Expr := Expression (Assoc);
7824 while Present (Comp) loop
7825 if Nkind (Comp) = N_Range then
7826 Process_Range_Update (Temp, Comp, Expr, Typ);
7828 Process_Component_Or_Element_Update (Temp, Comp, Expr, Typ);
7837 -- The attribute is replaced by a reference to the anonymous object
7839 Rewrite (N, New_Occurrence_Of (Temp, Loc));
7841 end Expand_Update_Attribute;
7847 procedure Find_Fat_Info
7849 Fat_Type : out Entity_Id;
7850 Fat_Pkg : out RE_Id)
7852 Rtyp : constant Entity_Id := Root_Type (T);
7855 -- All we do is use the root type (historically this dealt with
7856 -- VAX-float .. to be cleaned up further later ???)
7860 if Fat_Type = Standard_Short_Float then
7861 Fat_Pkg := RE_Attr_Short_Float;
7863 elsif Fat_Type = Standard_Float then
7864 Fat_Pkg := RE_Attr_Float;
7866 elsif Fat_Type = Standard_Long_Float then
7867 Fat_Pkg := RE_Attr_Long_Float;
7869 elsif Fat_Type = Standard_Long_Long_Float then
7870 Fat_Pkg := RE_Attr_Long_Long_Float;
7872 -- Universal real (which is its own root type) is treated as being
7873 -- equivalent to Standard.Long_Long_Float, since it is defined to
7874 -- have the same precision as the longest Float type.
7876 elsif Fat_Type = Universal_Real then
7877 Fat_Type := Standard_Long_Long_Float;
7878 Fat_Pkg := RE_Attr_Long_Long_Float;
7881 raise Program_Error;
7885 ----------------------------
7886 -- Find_Stream_Subprogram --
7887 ----------------------------
7889 function Find_Stream_Subprogram
7891 Nam : TSS_Name_Type) return Entity_Id
7893 Base_Typ : constant Entity_Id := Base_Type (Typ);
7894 Ent : constant Entity_Id := TSS (Typ, Nam);
7896 function Is_Available (Entity : RE_Id) return Boolean;
7897 pragma Inline (Is_Available);
7898 -- Function to check whether the specified run-time call is available
7899 -- in the run time used. In the case of a configurable run time, it
7900 -- is normal that some subprograms are not there.
7902 -- I don't understand this routine at all, why is this not just a
7903 -- call to RTE_Available? And if for some reason we need a different
7904 -- routine with different semantics, why is not in Rtsfind ???
7910 function Is_Available (Entity : RE_Id) return Boolean is
7912 -- Assume that the unit will always be available when using a
7913 -- "normal" (not configurable) run time.
7915 return not Configurable_Run_Time_Mode or else RTE_Available (Entity);
7918 -- Start of processing for Find_Stream_Subprogram
7921 if Present (Ent) then
7925 -- Stream attributes for strings are expanded into library calls. The
7926 -- following checks are disabled when the run-time is not available or
7927 -- when compiling predefined types due to bootstrap issues. As a result,
7928 -- the compiler will generate in-place stream routines for string types
7929 -- that appear in GNAT's library, but will generate calls via rtsfind
7930 -- to library routines for user code.
7932 -- Note: In the case of using a configurable run time, it is very likely
7933 -- that stream routines for string types are not present (they require
7934 -- file system support). In this case, the specific stream routines for
7935 -- strings are not used, relying on the regular stream mechanism
7936 -- instead. That is why we include the test Is_Available when dealing
7937 -- with these cases.
7939 if not Is_Predefined_Unit (Current_Sem_Unit) then
7940 -- Storage_Array as defined in package System.Storage_Elements
7942 if Is_RTE (Base_Typ, RE_Storage_Array) then
7944 -- Case of No_Stream_Optimizations restriction active
7946 if Restriction_Active (No_Stream_Optimizations) then
7947 if Nam = TSS_Stream_Input
7948 and then Is_Available (RE_Storage_Array_Input)
7950 return RTE (RE_Storage_Array_Input);
7952 elsif Nam = TSS_Stream_Output
7953 and then Is_Available (RE_Storage_Array_Output)
7955 return RTE (RE_Storage_Array_Output);
7957 elsif Nam = TSS_Stream_Read
7958 and then Is_Available (RE_Storage_Array_Read)
7960 return RTE (RE_Storage_Array_Read);
7962 elsif Nam = TSS_Stream_Write
7963 and then Is_Available (RE_Storage_Array_Write)
7965 return RTE (RE_Storage_Array_Write);
7967 elsif Nam /= TSS_Stream_Input and then
7968 Nam /= TSS_Stream_Output and then
7969 Nam /= TSS_Stream_Read and then
7970 Nam /= TSS_Stream_Write
7972 raise Program_Error;
7975 -- Restriction No_Stream_Optimizations is not set, so we can go
7976 -- ahead and optimize using the block IO forms of the routines.
7979 if Nam = TSS_Stream_Input
7980 and then Is_Available (RE_Storage_Array_Input_Blk_IO)
7982 return RTE (RE_Storage_Array_Input_Blk_IO);
7984 elsif Nam = TSS_Stream_Output
7985 and then Is_Available (RE_Storage_Array_Output_Blk_IO)
7987 return RTE (RE_Storage_Array_Output_Blk_IO);
7989 elsif Nam = TSS_Stream_Read
7990 and then Is_Available (RE_Storage_Array_Read_Blk_IO)
7992 return RTE (RE_Storage_Array_Read_Blk_IO);
7994 elsif Nam = TSS_Stream_Write
7995 and then Is_Available (RE_Storage_Array_Write_Blk_IO)
7997 return RTE (RE_Storage_Array_Write_Blk_IO);
7999 elsif Nam /= TSS_Stream_Input and then
8000 Nam /= TSS_Stream_Output and then
8001 Nam /= TSS_Stream_Read and then
8002 Nam /= TSS_Stream_Write
8004 raise Program_Error;
8008 -- Stream_Element_Array as defined in package Ada.Streams
8010 elsif Is_RTE (Base_Typ, RE_Stream_Element_Array) then
8012 -- Case of No_Stream_Optimizations restriction active
8014 if Restriction_Active (No_Stream_Optimizations) then
8015 if Nam = TSS_Stream_Input
8016 and then Is_Available (RE_Stream_Element_Array_Input)
8018 return RTE (RE_Stream_Element_Array_Input);
8020 elsif Nam = TSS_Stream_Output
8021 and then Is_Available (RE_Stream_Element_Array_Output)
8023 return RTE (RE_Stream_Element_Array_Output);
8025 elsif Nam = TSS_Stream_Read
8026 and then Is_Available (RE_Stream_Element_Array_Read)
8028 return RTE (RE_Stream_Element_Array_Read);
8030 elsif Nam = TSS_Stream_Write
8031 and then Is_Available (RE_Stream_Element_Array_Write)
8033 return RTE (RE_Stream_Element_Array_Write);
8035 elsif Nam /= TSS_Stream_Input and then
8036 Nam /= TSS_Stream_Output and then
8037 Nam /= TSS_Stream_Read and then
8038 Nam /= TSS_Stream_Write
8040 raise Program_Error;
8043 -- Restriction No_Stream_Optimizations is not set, so we can go
8044 -- ahead and optimize using the block IO forms of the routines.
8047 if Nam = TSS_Stream_Input
8048 and then Is_Available (RE_Stream_Element_Array_Input_Blk_IO)
8050 return RTE (RE_Stream_Element_Array_Input_Blk_IO);
8052 elsif Nam = TSS_Stream_Output
8053 and then Is_Available (RE_Stream_Element_Array_Output_Blk_IO)
8055 return RTE (RE_Stream_Element_Array_Output_Blk_IO);
8057 elsif Nam = TSS_Stream_Read
8058 and then Is_Available (RE_Stream_Element_Array_Read_Blk_IO)
8060 return RTE (RE_Stream_Element_Array_Read_Blk_IO);
8062 elsif Nam = TSS_Stream_Write
8063 and then Is_Available (RE_Stream_Element_Array_Write_Blk_IO)
8065 return RTE (RE_Stream_Element_Array_Write_Blk_IO);
8067 elsif Nam /= TSS_Stream_Input and then
8068 Nam /= TSS_Stream_Output and then
8069 Nam /= TSS_Stream_Read and then
8070 Nam /= TSS_Stream_Write
8072 raise Program_Error;
8076 -- String as defined in package Ada
8078 elsif Base_Typ = Standard_String then
8080 -- Case of No_Stream_Optimizations restriction active
8082 if Restriction_Active (No_Stream_Optimizations) then
8083 if Nam = TSS_Stream_Input
8084 and then Is_Available (RE_String_Input)
8086 return RTE (RE_String_Input);
8088 elsif Nam = TSS_Stream_Output
8089 and then Is_Available (RE_String_Output)
8091 return RTE (RE_String_Output);
8093 elsif Nam = TSS_Stream_Read
8094 and then Is_Available (RE_String_Read)
8096 return RTE (RE_String_Read);
8098 elsif Nam = TSS_Stream_Write
8099 and then Is_Available (RE_String_Write)
8101 return RTE (RE_String_Write);
8103 elsif Nam /= TSS_Stream_Input and then
8104 Nam /= TSS_Stream_Output and then
8105 Nam /= TSS_Stream_Read and then
8106 Nam /= TSS_Stream_Write
8108 raise Program_Error;
8111 -- Restriction No_Stream_Optimizations is not set, so we can go
8112 -- ahead and optimize using the block IO forms of the routines.
8115 if Nam = TSS_Stream_Input
8116 and then Is_Available (RE_String_Input_Blk_IO)
8118 return RTE (RE_String_Input_Blk_IO);
8120 elsif Nam = TSS_Stream_Output
8121 and then Is_Available (RE_String_Output_Blk_IO)
8123 return RTE (RE_String_Output_Blk_IO);
8125 elsif Nam = TSS_Stream_Read
8126 and then Is_Available (RE_String_Read_Blk_IO)
8128 return RTE (RE_String_Read_Blk_IO);
8130 elsif Nam = TSS_Stream_Write
8131 and then Is_Available (RE_String_Write_Blk_IO)
8133 return RTE (RE_String_Write_Blk_IO);
8135 elsif Nam /= TSS_Stream_Input and then
8136 Nam /= TSS_Stream_Output and then
8137 Nam /= TSS_Stream_Read and then
8138 Nam /= TSS_Stream_Write
8140 raise Program_Error;
8144 -- Wide_String as defined in package Ada
8146 elsif Base_Typ = Standard_Wide_String then
8148 -- Case of No_Stream_Optimizations restriction active
8150 if Restriction_Active (No_Stream_Optimizations) then
8151 if Nam = TSS_Stream_Input
8152 and then Is_Available (RE_Wide_String_Input)
8154 return RTE (RE_Wide_String_Input);
8156 elsif Nam = TSS_Stream_Output
8157 and then Is_Available (RE_Wide_String_Output)
8159 return RTE (RE_Wide_String_Output);
8161 elsif Nam = TSS_Stream_Read
8162 and then Is_Available (RE_Wide_String_Read)
8164 return RTE (RE_Wide_String_Read);
8166 elsif Nam = TSS_Stream_Write
8167 and then Is_Available (RE_Wide_String_Write)
8169 return RTE (RE_Wide_String_Write);
8171 elsif Nam /= TSS_Stream_Input and then
8172 Nam /= TSS_Stream_Output and then
8173 Nam /= TSS_Stream_Read and then
8174 Nam /= TSS_Stream_Write
8176 raise Program_Error;
8179 -- Restriction No_Stream_Optimizations is not set, so we can go
8180 -- ahead and optimize using the block IO forms of the routines.
8183 if Nam = TSS_Stream_Input
8184 and then Is_Available (RE_Wide_String_Input_Blk_IO)
8186 return RTE (RE_Wide_String_Input_Blk_IO);
8188 elsif Nam = TSS_Stream_Output
8189 and then Is_Available (RE_Wide_String_Output_Blk_IO)
8191 return RTE (RE_Wide_String_Output_Blk_IO);
8193 elsif Nam = TSS_Stream_Read
8194 and then Is_Available (RE_Wide_String_Read_Blk_IO)
8196 return RTE (RE_Wide_String_Read_Blk_IO);
8198 elsif Nam = TSS_Stream_Write
8199 and then Is_Available (RE_Wide_String_Write_Blk_IO)
8201 return RTE (RE_Wide_String_Write_Blk_IO);
8203 elsif Nam /= TSS_Stream_Input and then
8204 Nam /= TSS_Stream_Output and then
8205 Nam /= TSS_Stream_Read and then
8206 Nam /= TSS_Stream_Write
8208 raise Program_Error;
8212 -- Wide_Wide_String as defined in package Ada
8214 elsif Base_Typ = Standard_Wide_Wide_String then
8216 -- Case of No_Stream_Optimizations restriction active
8218 if Restriction_Active (No_Stream_Optimizations) then
8219 if Nam = TSS_Stream_Input
8220 and then Is_Available (RE_Wide_Wide_String_Input)
8222 return RTE (RE_Wide_Wide_String_Input);
8224 elsif Nam = TSS_Stream_Output
8225 and then Is_Available (RE_Wide_Wide_String_Output)
8227 return RTE (RE_Wide_Wide_String_Output);
8229 elsif Nam = TSS_Stream_Read
8230 and then Is_Available (RE_Wide_Wide_String_Read)
8232 return RTE (RE_Wide_Wide_String_Read);
8234 elsif Nam = TSS_Stream_Write
8235 and then Is_Available (RE_Wide_Wide_String_Write)
8237 return RTE (RE_Wide_Wide_String_Write);
8239 elsif Nam /= TSS_Stream_Input and then
8240 Nam /= TSS_Stream_Output and then
8241 Nam /= TSS_Stream_Read and then
8242 Nam /= TSS_Stream_Write
8244 raise Program_Error;
8247 -- Restriction No_Stream_Optimizations is not set, so we can go
8248 -- ahead and optimize using the block IO forms of the routines.
8251 if Nam = TSS_Stream_Input
8252 and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
8254 return RTE (RE_Wide_Wide_String_Input_Blk_IO);
8256 elsif Nam = TSS_Stream_Output
8257 and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
8259 return RTE (RE_Wide_Wide_String_Output_Blk_IO);
8261 elsif Nam = TSS_Stream_Read
8262 and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
8264 return RTE (RE_Wide_Wide_String_Read_Blk_IO);
8266 elsif Nam = TSS_Stream_Write
8267 and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
8269 return RTE (RE_Wide_Wide_String_Write_Blk_IO);
8271 elsif Nam /= TSS_Stream_Input and then
8272 Nam /= TSS_Stream_Output and then
8273 Nam /= TSS_Stream_Read and then
8274 Nam /= TSS_Stream_Write
8276 raise Program_Error;
8282 if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then
8283 return Find_Prim_Op (Typ, Nam);
8285 return Find_Inherited_TSS (Typ, Nam);
8287 end Find_Stream_Subprogram;
8293 function Full_Base (T : Entity_Id) return Entity_Id is
8297 BT := Base_Type (T);
8299 if Is_Private_Type (BT)
8300 and then Present (Full_View (BT))
8302 BT := Full_View (BT);
8308 -----------------------
8309 -- Get_Index_Subtype --
8310 -----------------------
8312 function Get_Index_Subtype (N : Node_Id) return Node_Id is
8313 P_Type : Entity_Id := Etype (Prefix (N));
8318 if Is_Access_Type (P_Type) then
8319 P_Type := Designated_Type (P_Type);
8322 if No (Expressions (N)) then
8325 J := UI_To_Int (Expr_Value (First (Expressions (N))));
8328 Indx := First_Index (P_Type);
8334 return Etype (Indx);
8335 end Get_Index_Subtype;
8337 -------------------------------
8338 -- Get_Stream_Convert_Pragma --
8339 -------------------------------
8341 function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
8346 -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity
8347 -- that a stream convert pragma for a tagged type is not inherited from
8348 -- its parent. Probably what is wrong here is that it is basically
8349 -- incorrect to consider a stream convert pragma to be a representation
8350 -- pragma at all ???
8352 N := First_Rep_Item (Implementation_Base_Type (T));
8353 while Present (N) loop
8354 if Nkind (N) = N_Pragma
8355 and then Pragma_Name (N) = Name_Stream_Convert
8357 -- For tagged types this pragma is not inherited, so we
8358 -- must verify that it is defined for the given type and
8362 Entity (Expression (First (Pragma_Argument_Associations (N))));
8364 if not Is_Tagged_Type (T)
8366 or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
8376 end Get_Stream_Convert_Pragma;
8378 ---------------------------------
8379 -- Is_Constrained_Packed_Array --
8380 ---------------------------------
8382 function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
8383 Arr : Entity_Id := Typ;
8386 if Is_Access_Type (Arr) then
8387 Arr := Designated_Type (Arr);
8390 return Is_Array_Type (Arr)
8391 and then Is_Constrained (Arr)
8392 and then Present (Packed_Array_Impl_Type (Arr));
8393 end Is_Constrained_Packed_Array;
8395 ----------------------------------------
8396 -- Is_Inline_Floating_Point_Attribute --
8397 ----------------------------------------
8399 function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
8400 Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
8402 function Is_GCC_Target return Boolean;
8403 -- Return True if we are using a GCC target/back-end
8404 -- ??? Note: the implementation is kludgy/fragile
8410 function Is_GCC_Target return Boolean is
8412 return not CodePeer_Mode
8413 and then not Modify_Tree_For_C;
8416 -- Start of processing for Is_Inline_Floating_Point_Attribute
8419 -- Machine and Model can be expanded by the GCC back end only
8421 if Id = Attribute_Machine or else Id = Attribute_Model then
8422 return Is_GCC_Target;
8424 -- Remaining cases handled by all back ends are Rounding and Truncation
8425 -- when appearing as the operand of a conversion to some integer type.
8427 elsif Nkind (Parent (N)) /= N_Type_Conversion
8428 or else not Is_Integer_Type (Etype (Parent (N)))
8433 -- Here we are in the integer conversion context
8435 -- Very probably we should also recognize the cases of Machine_Rounding
8436 -- and unbiased rounding in this conversion context, but the back end is
8437 -- not yet prepared to handle these cases ???
8439 return Id = Attribute_Rounding or else Id = Attribute_Truncation;
8440 end Is_Inline_Floating_Point_Attribute;